AnyEvent-XMPP-0.55/0000755000014500017510000000000012304452270013242 5ustar michaelstaffAnyEvent-XMPP-0.55/lib/0000755000014500017510000000000012304452270014010 5ustar michaelstaffAnyEvent-XMPP-0.55/lib/AnyEvent/0000755000014500017510000000000012304452270015541 5ustar michaelstaffAnyEvent-XMPP-0.55/lib/AnyEvent/XMPP.pm0000644000014500017510000003237012304451775016701 0ustar michaelstaffpackage AnyEvent::XMPP; no warnings; use strict; =head1 NAME AnyEvent::XMPP - An implementation of the XMPP Protocol =head1 VERSION Version 0.55 =cut our $VERSION = '0.55'; =head1 SYNOPSIS use AnyEvent::XMPP::Connection; or: use AnyEvent::XMPP::IM::Connection; or: use AnyEvent::XMPP::Client; =head1 DESCRIPTION This is the head module of the L XMPP client protocol (as described in RFC 3920 and RFC 3921) framework. L is a RFC 3920 conforming "XML" stream implementation for clients, which handles TCP connect up to the resource binding. And provides low level access to the XML nodes on the XML stream along with some high level methods to send the predefined XML stanzas. L is a more high level module, which is derived from L. It handles all the instant messaging client functionality described in RFC 3921. L is a multi account client class. It manages connections to multiple XMPP accounts and tries to offer a nice high level interface to XMPP communication. For a list of L see below. There are also other modules in this distribution, for example: L, L, L and those I forgot :-) Those modules might be helpful and/or required if you want to use this framework for XMPP. See also L for a discussion about the brokenness of XML in the XMPP specification. If you have any questions or seek for help look below under L. =head1 REQUIREMENTS One of the major drawbacks I see for AnyEvent::XMPP is the long list of required modules to make it work. =over 4 =item L For the I/O events, timers, TCP, TLS, DNS and I/O buffering. =item L The former L module has been outsourced to the L module to provide a more generic way for more other modules to register and call event callbacks. =item L For writing "XML". =item L For parsing partial "XML" stuff. =item L For SASL authentication =item L For SASL authentication =item L For stringprep profiles to handle JIDs. =item L For component authentication and old-style authentication. =back And yes, all these are essential for XMPP communication. Even though 'instant messaging' and 'presence' is a quite simple problem XMPP somehow was successful at making the task complicated enough to keep me busy for a long time. But all of that time wasn't only for the technology required to get it started, mostly it was for all the quirks, hacks and badly applied "XML" in the protocol which complicated the matter. =head1 RELEASE NOTES Here are some notes to the last releases (release of this version is at top): =head2 Version =over 4 =item * 0.55 Bugfixes, see Changes file. =item * 0.54 Add L, small bugfixes, see Changes file. =item * 0.53 Maintenance release. Patches for various small issues, see Changes file. =item * 0.52 Maintenance release. =item * 0.51 Maintenance release. Added a patch which fixes L compatibility and another fix w.r.t. memory leak in the parser. And added the original node to L (thanks go to mons@cpan.org). B Version 0.6 of L will be API incompatible! If you are already eager to try the new version out contact me! =item * 0.5 Maintenance release. Added a patch from Marcus Dubois for Ext::Pubsub. Also fixed some memleaks in L. Also wanted to note that the next version of AnyEvent::XMPP will have an incompatible API. If you are eager to try out the new complete rewrite of AnyEvent::XMPP contact me. =item * 0.4 Minor fixes and feature enhancements: Added old_style_ssl option for direct port 5223 SSL connections. Providing 'get_own_contact' for keeping track of own resources. The L extension was rewritten and provides a more sane API now. For details consult the Changes file in the distribution. =item * 0.3 Fixed some small bugs and improved documentation a bit, especially w.r.t. parameter passing of host and ports. =item * 0.2 Renamed module from L to L. L is herby deprecated! Rewrote the low-level socket stuff to use L and L. Removed blocking write functionality, which can't be supported that easily with L (however, if you want to wait until the send-buffer is empty you best use the C event of L). For more details consult the Changes file of the AnyEvent::XMPP distribution. =item * older For older release notes please have a look at the Changes file or CPAN. =back =head2 TODO There are still lots of items on the TODO list (see also the TODO file in the distribution of AnyEvent::XMPP). =head1 TEST SUITE If you are a developer and want to test either a server or maybe just whether this module passes some basic tests you might want to run the developer test suite. This test suite is not enabled by default because it requires some human interaction to set it up, please see L for hints about the setup procedure for the test suite. I wrote the test suite mostly because I wanted to make sure I didn't break something essential before a release. The tests don't cover everything and I don't plan to write a test for every single function in the API, that would slow down development considerably for me. But I hope that some grave show stopper bugs in releases are prevented with this test suite. The tests are also useful if you want to test a server implementation. But there are maybe of course conformance issues with L itself, so if you find something where L doesn't conform to the XMPP RFCs or XEPs consult the L section below. If you find a server that doesn't handle something correctly but you need to interact with it you are free to implement workarounds and send me a patch, or even ask me whether I might want to look into the issue (I can't guarantee anything here, but I want this module to be as interoperable as possible. But if the implementation of a workaround for some non-conformant software will complicate the code too much I'm probably not going to implement it.). Of course, if you find a bug in some server implementation don't forget to file a bugreport to them, one hack less in L means more time for bug fixing and improvements and new features. =head1 Why (yet) another XMPP module? The main outstanding feature of this module in comparison to the other XMPP (aka Jabber) modules out there is the support for L. L permits you to use this module together with other I/O event based programs and libraries (ie. L or L). The other modules could often only be integrated in those applications or libraries by using threads. I decided to write this module because I think CPAN lacks an event based XMPP module. Threads are unfortunately not an alternative in Perl at the moment due the limited threading functionality they provide and the global speed hit. I also think that a simple event based I/O framework might be a bit easier to handle than threads. Another thing was that I didn't like the APIs of the other modules. In L I try to provide low level modules for speaking XMPP as defined in RFC 3920 and RFC 3921 (see also L and L). But I also try to provide a high level API for easier usage for instant messaging tasks and clients (eg. L). =head1 Supported extensions See L for a list. =head1 EXAMPLES Following examples are included in this distribution: =over 4 =item B This example script just connects to a server and sends a message and also displays incoming messages on stdout. =item B See below. =item B See below. =item B These three scripts implements a global room scan. C takes a list of servers (the file is called C which has the same format as the xml file at L). It then scans all servers for chat room services and lists them into a file C, which is a L dump. C then reads that file and queries all services for rooms, and then all rooms for their occupants. The output file is C, also a L dump, which in turn can be read with C, which transform the data structures into something human readable. These scripts are a bit hacky and quite complicated, but maybe it's of any value for someone. You might note L which is a module that handles request-throttling (You don't want to flood the server and risk getting the admins attention :). =item B This is a (basic) skeleton for a jabber component. =item B This is a simple out of band file transfer receiver bot. It uses C to fetch the files and also has the sample functionality of sending a file url for someone who sends the bot a 'send ' message. =item B This is a example script which allows you to register, unregister and change your password for accounts. Execute it without arguments for more details. =item B This is a small example tool that allows you to fetch the software version, disco info and disco items information about a JID. =item B This is a simple bot that will read lines from a file and recite them when you send it a message. It will also automatically allow you to subscribe to it. Start it without commandline arguments to be informed about the usage. =item B This is a simple example script that will retrieve the roster for an account and print it to stdout. You start it like this: samples/# ./retrieve_roster =item B This is just a small example which should display the avatar of the account you connect to. It can be used like this: samples/# ./display_avatar =back For others, which the author might forgot or didn't want to list here see the C directory. More examples will be included in later releases, please feel free to ask the L if you have any questions about the API. There is also an IRC channel, see L. =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 BUGS Please note that I'm currently (July 2007) the only developer on this project and I'm very busy with my studies in Computer Science. If you want to ease my workload or want timely releases, please send me patches instead of bug reports or feature requests. I won't forget the reports or requests if you can't or didn't send patches, but I can't gurantee immediate response. But I will of course try to fix/implement them as soon as possible! Also try to be as precise as possible with bug reports, if you can't send a patch, it would be best if you find out which code doesn't work and tell me why. Please report any bugs or feature requests to C, or through the web interface at L. I will be notified and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc AnyEvent::XMPP You can also look for information at: =over 4 =item * IRC: AnyEvent::XMPP IRC Channel IRC Network: http://freenode.net/ Server : chat.freenode.net Channel : #ae_xmpp Feel free to join and ask questions! =item * AnyEvent::XMPP Project Site L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * RT: CPAN's request tracker L =item * Search CPAN L =back =head1 ACKNOWLEDGEMENTS Thanks to the XSF for the development of an open instant messaging protocol (even though it uses "XML"). And thanks to all people who had to listen to my desperate curses about the brokenness/braindeadness of XMPP. Without you I would've never brought this module to a usable state. Thanks to: =over 4 =item * J. Cameijo Cerdeira For pointing out a serious bug in C in L and suggesting to add a timeout argument to the C method of L. =item * Carlo von Loesch (aka lynX) L For pointing out some typos. =item * All other people .. ... I mentioned in the CONTRIBUTORS file which comes with the L distribution. =back =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.55/lib/AnyEvent/XMPP/0000755000014500017510000000000012304452270016325 5ustar michaelstaffAnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Ext/0000755000014500017510000000000012304452270017065 5ustar michaelstaffAnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Ext/Version.pm0000644000014500017510000001210212066334771021056 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::Version; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Util qw/simxml/; use AnyEvent::XMPP::Ext; use strict; our @ISA = qw/AnyEvent::XMPP::Ext/; =head1 NAME AnyEvent::XMPP::Ext::Version - Software version =head1 SYNOPSIS use AnyEvent::XMPP::Ext::Version; my $version = AnyEvent::XMPP::Ext::Version->new; $version->set_name ("My client"); $version->set_version ("0.3"); $version->set_os (`uname -a`); $disco->enable_feature ($version->disco_feature); =head1 DESCRIPTION This module defines an extension to provide the abilities to answer to software version requests and to request software version from other entities. See also XEP-0092 This class is derived from L and can be added as extension to objects that implement the L interface or derive from it. =head1 METHODS =over 4 =item B Creates a new software version handle. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } sub disco_feature { xmpp_ns ('version') } sub init { my ($self) = @_; $self->set_name ("AnyEvent::XMPP"); $self->set_version ("$AnyEvent::XMPP::VERSION"); $self->{cb_id} = $self->reg_cb ( iq_get_request_xml => sub { my ($self, $con, $node, $handled) = @_; if ($self->handle_query ($con, $node)) { $$handled = 1; } } ); } =item B This method sets the software C<$name> string, the default is "AnyEvent::XMPP". =cut sub set_name { my ($self, $name) = @_; $self->{name} = $name; } =item B This method sets the software C<$version> string that is replied. The default is C<$AnyEvent::XMPP::VERSION>. =cut sub set_version { my ($self, $version) = @_; $self->{version} = $version; } =item B This method sets the operating system string C<$os>. If you pass undef the string will be removed. The default is no operating system string at all. You may want to pass something like this: $version->set_os (`uname -s -r -m -o`); =cut sub set_os { my ($self, $os) = @_; $self->{os} = $os; delete $self->{os} unless defined $os; } sub version_result { my ($self) = @_; ( { name => 'name' , childs => [ $self->{name} ] }, { name => 'version', childs => [ $self->{version} ] }, (defined $self->{os} ? { name => 'os', childs => [ $self->{os} ] } : () ), ) } sub handle_query { my ($self, $con, $node) = @_; if (my ($q) = $node->find_all ([qw/version query/])) { my @result = $self->version_result; $con->reply_iq_result ( $node, { defns => 'version', node => { ns => 'version', name => 'query', childs => [ @result ] } } ); return 1 } () } sub _version_from_node { my ($node) = @_; my (@vers) = $node->find_all ([qw/version query/], [qw/version version/]); my (@name) = $node->find_all ([qw/version query/], [qw/version name/]); my (@os) = $node->find_all ([qw/version query/], [qw/version os/]); my $v = {}; $v->{jid} = $node->attr ('from'); $v->{version} = $vers[0]->text if @vers; $v->{name} = $name[0]->text if @name; $v->{os} = $os[0]->text if @os; $v } =item B This method sends a version request to C<$dest> on the connection C<$con>. C<$cb> is the callback that will be called if either an error occured or the result was received. The callback will also be called after the default IQ timeout for the connection C<$con>. The second argument for the callback will be either undef if no error occured or a L error. The first argument will be a hash reference with the following fields: =over 4 =item jid The JID of the entity this version reply belongs to. =item version The software version string of the entity. =item name The software name of the entity. =item os The operating system of the entity, which might be undefined if none was provided. =back Here an example of the structure of the hash reference: { jid => 'juliet@capulet.com/balcony', name => 'Exodus', version => '0.7.0.4', os => 'Windows-XP 5.01.2600', } =cut sub request_version { my ($self, $con, $dest, $cb) = @_; $con->send_iq (get => { defns => 'version', node => { ns => 'version', name => 'query' } }, sub { my ($n, $e) = @_; if ($e) { $cb->(undef, $e); } else { $cb->(_version_from_node ($n), undef); } }, to => $dest); } sub DESTROY { my ($self) = @_; $self->unreg_cb ($self->{cb_id}) } =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.55/lib/AnyEvent/XMPP/Ext/Receipts.pm0000644000014500017510000002372112300136351021201 0ustar michaelstaff# vim:ts=4:sw=4:et package AnyEvent::XMPP::Ext::Receipts; use AnyEvent; use AnyEvent::XMPP::Ext; use AnyEvent::XMPP::Util qw/is_bare_jid/; use AnyEvent::XMPP::Namespaces qw/set_xmpp_ns_alias/; use Data::Dumper; use warnings; use strict; our @ISA = qw/AnyEvent::XMPP::Ext/; =head1 NAME AnyEvent::XMPP::Ext::Receipts - XEP-0184 message receipts =head1 SYNOPSIS use AnyEvent::XMPP::Ext::Disco; use AnyEvent::XMPP::Ext::Receipts; my $disco = AnyEvent::XMPP::Ext::Disco->new(); $xmpp->add_extension($disco); my $receipts = AnyEvent::XMPP::Ext::Receipts->new(disco => $disco); $xmpp->add_extension($receipts); $disco->enable_feature($receipts->disco_feature); =head1 DESCRIPTION This module adds support for XEP-0184 message receipts. Message receipts provide a way to verify that messages were received by the recipient, as long as the recipient's client supports it. Note that you need to send messages with message receipts to full Jabber IDs (e.g. jabber@example.com/android3948128), not bare Jabber IDs (e.g. jabber@example.com). =head1 METHODS =over =cut # A hash which stores whether a certain presence supports XEP-0184 receipts. # Entries are added after we actually send a message and entries are purged # when the presence goes offline or is replaced (since the new presence might # have a different feature set while keeping the same jid). my %supports_receipts = (); # A hash which stores timers by message id. When a message is acknowledged, the # corresponding timer is deleted. my %timers = (); =item B Creates a new receipts handle. The following keys can be specified: =over =item B An C object so that it can be figured out whether the recipient supports message receipts (via service discovery). This is required. =item B If you pass a value that evaluates to true, debug messages will be printed to STDOUT. =item B Amount of time in seconds after which messages will be re-sent when no receipt was received. Of course messages will only be re-sent if the recipient is known to support message receipts. Defaults to 30 (seconds). Set to 0 to disable automatic re-sending. =back Here is an example with all keys set: my $receipts = AnyEvent::XMPP::Ext::Receipts->new( disco => $disco, auto_resend => 30, debug => 1, ); =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; die "You did not pass an AnyEvent::XMPP::Ext::Disco object as 'disco', see SYNOPSIS" unless defined($self->{disco}); $self->{debug} //= 0; # Re-send messages after unacknowledged for 30 seconds. $self->{auto_resend} //= 30; $self->init; $self } sub init { my ($self) = @_; set_xmpp_ns_alias(receipts => 'urn:xmpp:receipts'); $self->reg_cb( ext_before_message_xml => sub { my ($self, $con, $node) = @_; # Figure out if this is a receive receipt (XEP-0184), such a message # looks like this: # # # my ($receipt) = $node->find_all ([qw/receipts received/]); if (defined($receipt)) { my $id = $receipt->attr('id'); print "(xep0184) message $id acknowledged\n" if $self->{debug}; delete $timers{$id}; # If the recipient acknowledged our message, he *obviously* # supports receipts. $supports_receipts{$node->attr('from')} = 1; $self->stop_event; } # Figure out if this is a message which requests a receipt, such as # # Did you get this? # # my ($request) = $node->find_all ([qw/receipts request/]); if (defined($request)) { my $id = $node->attr('id'); print "(xep0184) sending receipt for $id\n" if $self->{debug}; # A receipt looks like this: # # # $con->send_message( $node->attr('from'), $node->attr('type'), # Add a receipt request tag to the message, like this: # sub { my $w = shift; $w->addPrefix('urn:xmpp:receipts', ''); $w->startTag(['urn:xmpp:receipts', 'received'], id => $id); $w->endTag; }, _is_receipt => 1); } }, ext_before_send_message_hook => sub { my ($self, $con, $id, $to, $type, $attrs, $create_cb) = @_; # We can only handle full jids as per XEP-0184 5.1: # "If the sender knows only the recipient's bare JID, it cannot # cannot determine [...] whether the intended recipient supports # the Message Delivery Receipts protoocl. [...] the sender MUST NOT # depend on receiving an ack message in reply." # If we can’t rely on ack messages, receipts are useless. return if is_bare_jid($to); # If we have already figured out that the recipient does not # support message receipts, sending them (and especially waiting # for acknowledge) is pointless. return if exists($supports_receipts{$to}) && !$supports_receipts{$to}; # If this is a message receipt (sent by us), do not add a receipt # request, that might lead to an endless loop. if ($attrs->{_is_receipt}) { # XXX: The need to check a special attribute and delete it here # is ugly, but the only way the API provides, as far as I can # tell. Patches welcome. delete $attrs->{_is_receipt}; return; } # Add a receipt request tag to the message, like this: # push @$create_cb, sub { my $w = shift; $w->addPrefix('urn:xmpp:receipts', ''); $w->startTag(['urn:xmpp:receipts', 'request']); $w->endTag; }; if ($self->{auto_resend} > 0) { print "(xep0184) expecting reply within " . $self->{auto_resend} . "s\n" if $self->{debug}; # This timer will be deleted when the recipient acknowledges the # message. Otherwise, it re-sends the message. $timers{$id} = AnyEvent->timer( after => $self->{auto_resend}, cb => sub { print "(xep0184) timeout for id $id\n" if $self->{debug}; if (!$con->is_connected) { print "(xep0184) skipping re-send: jabber connection offline\n" if $self->{debug}; return; } if (!exists($supports_receipts{$to}) || !$supports_receipts{$to}) { # If we don’t know whether the recipient supports # message receipts (and we should by now, since we # start a discovery request when sending the message), # we don’t re-send. Better safe than duplicate msgs :). print "(xep0184) not re-sending, no receipts support\n" if $self->{debug}; return; } print "(xep0184) re-sending message $id to $to\n" if $self->{debug}; $con->send_message($to, $type, undef, %$attrs); }); } # If we don’t know yet whether the recipient supports message # receipts, let’s send a discovery request. if (!exists($supports_receipts{$to})) { $self->{disco}->request_info($con, $to, undef, sub { my ($disco, $items, $error) = @_; if ($error) { # We can’t figure out whether the recipient supports # receipts, most likely due to a timeout to our # request. We will retry the next time a message is # sent anyways, so do nothing. print "(xep0184) error discovering features: " . $error->string . "\n" if $self->{debug}; return; } $supports_receipts{$to} = exists($items->features()->{'urn:xmpp:receipts'}); print "(xep0184) cache: $to = " . $supports_receipts{$to} . "\n" if $self->{debug}; }); } }, ext_before_presence_xml => sub { my ($self, $con, $node) = @_; if (($node->attr('type') // '') eq 'unavailable') { my $jid = $node->attr('from'); print "(xep0184) $jid is offline, invalidating cache\n" if $self->{debug}; delete $supports_receipts{$jid}; } }, ); } sub disco_feature { 'urn:xmpp:receipts'; } =back =head1 AUTHOR Michael Stapelberg, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2012 Michael Stapelberg 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.55/lib/AnyEvent/XMPP/Ext/RegisterForm.pm0000644000014500017510000001626312066334771022055 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::RegisterForm; use strict; use AnyEvent::XMPP::Util; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Ext::DataForm; use AnyEvent::XMPP::Ext::OOB; =head1 NAME AnyEvent::XMPP::Ext::RegisterForm - Handle for in band registration =head1 SYNOPSIS my $con = AnyEvent::XMPP::Connection->new (...); ... $con->do_in_band_register (sub { my ($form, $error) = @_; if ($error) { print "ERROR: ".$error->string."\n" } else { if ($form->type eq 'simple') { if ($form->has_field ('username') && $form->has_field ('password')) { $form->set_field ( username => 'test', password => 'qwerty', ); $form->submit (sub { my ($form, $error) = @_; if ($error) { print "SUBMIT ERROR: ".$error->string."\n" } else { print "Successfully registered as ".$form->field ('username')."\n" } }); } else { print "Couldn't fill out the form: " . $form->field ('instructions') ."\n"; } } elsif ($form->type eq 'data_form' { my $dform = $form->data_form; ... fill out the form $dform (of type AnyEvent::XMPP::DataForm) ... $form->submit_data_form ($dform, sub { my ($form, $error) = @_; if ($error) { print "DATA FORM SUBMIT ERROR: ".$error->string."\n" } else { print "Successfully registered as ".$form->field ('username')."\n" } }) } } }); =head1 DESCRIPTION This module represents an in band registration form which can be filled out and submitted. You can get an instance of this class only by requesting it from a L by calling the C method. =over 4 =item B Usually the constructor takes no arguments except when you want to construct an answer form, then you call the constructor like this: If you have legacy form fields as a hash ref in C<$filled_legacy_form>: AnyEvent::XMPP::Ext::RegisterForm ( legacy_form => $filled_legacy_form, answered => 1 ); If you have a data form in C<$answer_data_form>: AnyEvent::XMPP::Ext::RegisterForm ( legacy_form => $answer_data_form, answered => 1 ); =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self } =item B This method tries to fill out a form which was received from the other end. It enters the username and password and returns a new L object which is the answer form. B This function is just a heuristic to fill out a form for automatic registration, but it might fail if the forms are more complex and have required fields that we don't know. Registration without user interaction is theoretically not possible because forms can be different from server to server and require different information. Please also have a look at XEP-0077. Note that if the form is more complicated this method will not work and it's not guranteed that the registration will be successful. Calling this method on a answer form (where C returns true) will have an undefined result. =cut sub try_fillout_registration { my ($self, $username, $password) = @_; my $form; my $nform; if (my $df = $self->get_data_form) { my $af = AnyEvent::XMPP::Ext::DataForm->new; $af->make_answer_form ($df); $af->set_field_value (username => $username); $af->set_field_value (password => $password); $nform = $af; } else { $form = { username => $username, password => $password }; } return AnyEvent::XMPP::Ext::RegisterForm->new ( data_form => $nform, legacy_form => $form, answered => 1 ); } =item B This method will return a true value if this form was returned by eg. C or generally represents an answer form. =cut sub is_answer_form { my ($self) = @_; $self->{answered} } =item B This method returns true if the received form were just the current registration data. Basically this method returns true when you are already registered to the server. =cut sub is_already_registered { my ($self) = @_; exists $self->{legacy_form} && exists $self->{legacy_form}->{registered} } =item B This method returns a hash with the keys being the fields of the legacy form as described in the XML scheme of XEP-0077. If the form contained just nodes the keys will have undef as value. If the form contained also register information, in case C returns a true value, the values will contain the strings for the fields. =cut sub get_legacy_form_fields { my ($self) = @_; $self->{legacy_form} } =item B This method returns the L that came with the registration response. If no data form was provided by the server this method returns undef. =cut sub get_data_form { my ($self) = @_; $self->{data_form} } =item B This method returns a hash like the one returned from the function C in L. It contains the out of band data for this registration form. =cut sub get_oob { my ($self) = @_; $self->{oob} } sub init_new_form { my ($self, $formnode) = @_; my $df = AnyEvent::XMPP::Ext::DataForm->new; $df->from_node ($formnode); $self->{data_form} = $df; } sub _get_legacy_form { my ($self, $node) = @_; my $form = {}; my ($qnode) = $node->find_all ([qw/register query/]); return $form unless $qnode; for ($qnode->nodes) { if ($_->eq_ns ('register')) { $form->{$_->name} = $_->text; } } $form } sub init_from_node { my ($self, $node) = @_; if (my (@form) = $node->find_all ([qw/register query/], [qw/data_form x/])) { $self->init_new_form (@form); } if (my ($xoob) = $node->find_all ([qw/register query/], [qw/x_oob x/])) { $self->{oob} = AnyEvent::XMPP::Ext::OOB::url_from_node ($xoob); } $self->{legacy_form} = $self->_get_legacy_form ($node); } =item B This method returns a list of C nodes. =cut sub answer_form_to_simxml { my ($self) = @_; if ($self->{data_form}) { my $sxl = $self->{data_form}->to_simxml; return $sxl; } else { my @childs; my $lf = $self->get_legacy_form_fields; for (keys %$lf) { push @childs, { ns => 'register', dns => 'register', name => $_, childs => [ $lf->{$_} ] } } return @childs; } } =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::RegisterForm AnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Ext/Registration.pm0000644000014500017510000001520112066334771022106 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::Registration; use strict; use AnyEvent::XMPP::Util; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Ext::RegisterForm; =head1 NAME AnyEvent::XMPP::Ext::Registration - Handles all tasks of in band registration =head1 SYNOPSIS my $con = AnyEvent::XMPP::Connection->new (...); $con->reg_cb (stream_pre_authentication => sub { my ($con) = @_; my $reg = AnyEvent::XMPP::Ext::Registration->new (connection => $con); $reg->send_registration_request (sub { my ($reg, $form, $error) = @_; if ($error) { # error handling } else { my $af = $form->try_fillout_registration ("tester", "secret"); $reg->submit_form ($af, sub { my ($reg, $ok, $error, $form) = @_; if ($ok) { # registered successfully! $con->authenticate } else { # error if ($form) { # we got an alternative form! # fill it out and submit it with C again } } }); } }); 0 }); =head1 DESCRIPTION This module handles all tasks of in band registration that are possible and specified by XEP-0077. It's mainly a helper class that eases some tasks such as submitting and retrieving a form. =cut =head1 METHODS =over 4 =item B This is the constructor for a registration object. =over 4 =item connection This must be a L (or some other subclass of that) object. This argument is required. =back =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } sub init { my ($self) = @_; #... } =item B This method sends a register form request. C<$cb> will be called when either the form arrived or an error occured. The first argument of C<$cb> is always C<$self>. If the form arrived the second argument of C<$cb> will be a L object. If an error occured the second argument will be undef and the third argument will be a L object. For hints how L should be filled out look in XEP-0077. Either you have legacy form fields, out of band data or a data form. See also L in L. =cut sub send_registration_request { my ($self, $cb) = @_; my $con = $self->{connection}; $con->send_iq (get => { defns => 'register', node => { ns => 'register', name => 'query' } }, sub { my ($node, $error) = @_; my $form; if ($node) { $form = AnyEvent::XMPP::Ext::RegisterForm->new; $form->init_from_node ($node); } else { $error = AnyEvent::XMPP::Error::Register->new ( node => $error->xml_node, register_state => 'register' ); } $cb->($self, $form, $error); }); } sub _error_or_form_cb { my ($self, $e, $cb) = @_; $e = $e->xml_node; my $error = AnyEvent::XMPP::Error::Register->new ( node => $e, register_state => 'submit' ); if ($e->find_all ([qw/register query/], [qw/data_form x/])) { my $form = AnyEvent::XMPP::Ext::RegisterForm->new; $form->init_from_node ($e); $cb->($self, 0, $error, $form) } else { $cb->($self, 0, $error, undef) } } =item B This method sends an unregistration request. For description of the semantics of the callback in C<$cb> plase look in the description of the C method below. =cut sub send_unregistration_request { my ($self, $cb) = @_; my $con = $self->{connection}; $con->send_iq (set => { defns => 'register', node => { ns => 'register', name => 'query', childs => [ { ns => 'register', name => 'remove' } ]} }, sub { my ($node, $error) = @_; if ($node) { $cb->($self, 1) } else { $self->_error_or_form_cb ($error, $cb); } }); } =item B This method sends a password change request for the user C<$username> with the new password C<$password>. For description of the semantics of the callback in C<$cb> plase look in the description of the C method below. =cut sub send_password_change_request { my ($self, $username, $password, $cb) = @_; my $con = $self->{connection}; $con->send_iq (set => { defns => 'register', node => { ns => 'register', name => 'query', childs => [ { ns => 'register', name => 'username', childs => [ $username ] }, { ns => 'register', name => 'password', childs => [ $password ] }, ]} }, sub { my ($node, $error) = @_; if ($node) { $cb->($self, 1, undef, undef) } else { $self->_error_or_form_cb ($error, $cb); } }); } =item B This method submits the C<$form> which should be of type L and should be an answer form. C<$con> is the connection on which to send this form. C<$cb> is the callback that will be called once the form has been submitted and either an error or success was received. The first argument to the callback will be the L object, the second will be a boolean value that is true when the form was successfully transmitted and everything is fine. If the second argument is false then the third argument is a L object. If the error contained a data form which is required to successfully make the request then the fourth argument will be a L which you should fill out and send again with C. For the semantics of such an error form see also XEP-0077. =cut sub submit_form { my ($self, $form, $cb) = @_; my $con = $self->{connection}; $con->send_iq (set => { defns => 'register', node => { ns => 'register', name => 'query', childs => [ $form->answer_form_to_simxml ]} }, sub { my ($n, $e) = @_; if ($n) { $cb->($self, 1, undef, undef) } else { $self->_error_or_form_cb ($e, $cb); } }); } =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::Ext::Registration AnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Ext/Pubsub.pm0000644000014500017510000001731012066334771020677 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::Pubsub; use strict; use AnyEvent::XMPP::Util qw/simxml split_uri/; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Ext; our @ISA = qw/AnyEvent::XMPP::Ext/; =head1 NAME AnyEvent::XMPP::Ext::Pubsub - Implements XEP-0060: Publish-Subscribe =head1 SYNOPSIS my $con = AnyEvent::XMPP::Connection->new (...); $con->add_extension (my $ps = AnyEvent::XMPP::Ext::Pubsub->new); ... =head1 DESCRIPTION This module implements all tasks of handling the publish subscribe mechanism. (partially implemented) =cut sub handle_incoming_pubsub_event { my ($self, $node) = @_; my (@items); if(my ($q) = $node->find_all ([qw/pubsub_ev items/])) { foreach($q->find_all ([qw/pubsub_ev item/])) { push @items, $_; } } $self->event(pubsub_recv => @items); } =head1 METHODS =over 4 =item B This is the constructor for a pubsub object. It takes no further arguments. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } sub init { my ($self) = @_; $self->reg_cb ( ext_before_message_xml => sub { my ($self, $con, $node) = @_; my $handled = 0; for ($node->find_all ([qw/pubsub_ev event/])) { $self->stop_event; $self->handle_incoming_pubsub_event($_); } $handled } ); } =item B C<$con> is the connection already established, C<$uri> is the name of the node to be created C<$cb> is the callback Try to remove a node. =cut sub delete_node { my ($self, $con, $uri, $cb) = @_; my ($service, $node) = split_uri ($uri); $con->send_iq ( set => sub { my ($w) = @_; simxml ($w, defns => 'pubsub_own', node => { name => 'pubsub', childs => [ { name => 'delete', attrs => [ node => $node ] }, ] }); }, sub { my ($node, $err) = @_; $cb->(defined $err ? $err : ()) if $cb; }, (defined $service ? (to => $service) : ()) ); } =item B C<$con> is the connection already established, C<$uri> is the name of the node to be created C<$cb> is the callback Try to create a node. =cut sub create_node { my ($self, $con, $uri, $cb) = @_; my ($service, $node) = split_uri ($uri); $con->send_iq ( set => sub { my ($w) = @_; simxml ($w, defns => 'pubsub', node => { name => 'pubsub', childs => [ { name => 'create', attrs => [ node => $node ] }, { name => 'configure' } ] }); }, sub { my ($node, $err) = @_; $cb->(defined $err ? $err : ()) if $cb; }, (defined $service ? (to => $service) : ()) ); } =item B C<$con> is the connection already established, C<$uri> is the name of the node to be created C<$cb> is the callback Try to retrieve items. =cut sub subscribe_node { my ($self, $con, $uri, $cb) = @_; my $jid = $con->jid; my ($service, $node) = split_uri ($uri); $con->send_iq ( set => sub { my ($w) = @_; simxml ($w, defns => 'pubsub', node => { name => 'pubsub', childs => [ { name => 'subscribe', attrs => [ node => $node, jid => $jid ] } ] }); }, sub { my ($node, $err) = @_; $cb->(defined $err ? $err : ()) if $cb; }, (defined $service ? (to => $service) : ()) ); } =item B($con, $uri, $bc)> C<$con> is the connection already established, C<$uri> is the name of the node to be created C<$cb> is the callback Try to unsubscribe from a node. =cut sub unsubscribe_node { my ($self, $con, $uri, $cb) = @_; my $jid = $con->jid; my ($service, $node) = split_uri ($uri); $con->send_iq ( set => sub { my ($w) = @_; simxml ($w, defns => 'pubsub', node => { name => 'pubsub', childs => [ { name => 'unsubscribe', attrs => [ node => $node, jid => $jid ] } ] }); }, sub { my ($node, $err) = @_; $cb->(defined $err ? $err : ()) if $cb; }, (defined $service ? (to => $service) : ()) ); } =item B C<$con> is the connection already established, C<$uri> is the name of the node to be created C<$create_cb> is the callback C<$cb> is the callback Try to publish an item. =cut sub publish_item { my ($self, $con, $uri, $create_cb, $cb) = @_; my ($service, $node) = split_uri ($uri); $con->send_iq ( set => sub { my ($w) = @_; simxml ($w, defns => 'pubsub', node => { name => 'pubsub', childs => [ { name => 'publish', attrs => [ node => $node ], childs => [ { name => 'item', childs => [ $create_cb ] } ] }, ] }); }, sub { my ($node, $err) = @_; warn "OK $create_cb / $cb\n"; $cb->(defined $err ? $err : ()) if $cb; }, (defined $service ? (to => $service) : ()) ); } =item B C<$con> is the connection already established, C<$uri> is the name of the node to be created C<$cb> is the callback Try to retrieve items. =cut sub retrieve_items { my ($self, $con, $uri, $cb) = @_; my($service, $node) = split_uri ($uri); $con->send_iq ( get => sub { my ($w) = @_; simxml ($w, defns => 'pubsub', node => { name => 'pubsub', childs => [ { name => 'items', attrs => [ node => $node ] } ] }); }, sub { my ($node, $err) = @_; $cb->(defined $err ? $err : ()) if $cb; }, (defined $service ? (to => $service) : ()) ); } =item B C<$con> is the connection already established, C<$uri> is the name of the node to be created C<$id> is the id of the entry to be retrieved C<$cb> is the cb Try to retrieve item. =cut sub retrieve_item { my ($self, $con, $uri, $id, $cb) = @_; my($service, $node) = split_uri ($uri); $con->send_iq ( get => sub { my ($w) = @_; simxml( $w, defns => 'pubsub', node => { name => 'pubsub', childs => [ { name => 'items', attrs => [ node => $node ], childs => [ { name => 'item', attrs => [ id => $id ] }] } ] }); }, sub { my ($node, $err) = @_; $cb->(defined $err ? $err : ()) if $cb; }, (defined $service ? (to => $service) : ()) ); } =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 CONTRIBUTORS Chris Miceli - additional work on the pubsub extension =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::Ext::Pubsub AnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Ext/VCard.pm0000644000014500017510000003105412066334771020437 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::VCard; use AnyEvent::XMPP::Ext; no warnings; use strict; use MIME::Base64; use Digest::SHA qw/sha1_hex/; use Scalar::Util; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Util qw/prep_bare_jid/; our @ISA = qw/AnyEvent::XMPP::Ext/; =head1 NAME AnyEvent::XMPP::Ext::VCard - VCards (XEP-0054 & XEP-0084) =head1 SYNOPSIS use AnyEvent::XMPP::Ext::VCard; my $vcard = AnyEvent::XMPP::Ext::VCard->new; $con->reg_cb ( stream_ready => sub { $vcard->hook_on ($con) } ); $vcard->retrieve ($con, 'elmex@jabber.org', sub { my ($jid, $vcard, $error) = @_; if ($error) { warn "couldn't get vcard for elmex@jabber.org: " . $error->string . "\n"; } else { print "vCard nick for elmex@jabber.org: ".$vcard->{NICKNAME}."\n"; print "Avatar hash for elmex@jabber.org: ".$vcard->{_avatar_hash}."\n"; } }); $vcard->store ($con, undef, { NICKNAME => 'net-xmpp2' }, sub { my ($error) = @_; if ($error) { warn "upload failed: " . $error->string . "\n"; } else { print "upload successful\n"; } }); $disco->enable_feature ($vcard->disco_feature); =head1 DESCRIPTION This extension handles setting and retrieval of the VCard and the VCard based avatars. For example see the test suite of L. =head1 METHODS =over 4 =item B Creates a new vcard extension. It can take a C argument, which should be a tied hash which should be able to save the retrieved vcards. If no C is set a internal hash will be used and the vcards will be retrieved everytime the program is restarted. The keys will be the stringprepped bare JIDs of the people we got a vcard from and the value will be a non-cyclic hash/array datastructure representing the vcard. About this datastructure see below at B. If you want to support avatars correctly make sure you hook up the connection via the C method. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } sub init { my ($self) = @_; $self->{cb_id} = $self->reg_cb ( ext_before_vcard => sub { my ($self, $jid, $vcard) = @_; my $vc = $self->{cache}->{prep_bare_jid ($jid)} = $vcard; } ); } sub disco_feature { xmpp_ns ('vcard') } =item B C<$con> must be an object of the class L (or derived). Once the vCard extension has been hooked up on a connection it will add the avatar information to all outgoing presence stanzas. IMPORTANT: You need to hook on the connection B it was connected. The initial presence stanza needs to contain the information that we support avatars. The vcard will automatically retrieved if the session wasn't already started. Otherwise you will have to retrieve the vcard manually if you hook it up after the C event was received. You can prevent the automatic retrieval by giving a true value in C<$dont_retrieve_vcard>. However, just make sure to hook up on any connection before it is connected if you want to offer avatar support on it. Best is probably to do it like this: my $vcard = AnyEvent::XMPP::Ext::VCard->new; $con->reg_cb ( stream_ready => sub { $vcard->hook_on ($con) } ); =cut sub hook_on { my ($self, $con, $dont_retrieve_vcard) = @_; Scalar::Util::weaken $self; my $rid = $con->reg_cb ( ext_before_send_presence_hook => sub { my ($con, $id, $type, $attrs, $create_cb) = @_; my $chlds; my $vc = $self->my_vcard ($con); if ($vc && !$vc->{_avatar}) { push @$chlds, { ns => xmpp_ns ('vcard_upd'), name => 'photo' } } elsif ($vc && $vc->{_avatar}) { push @$chlds, { ns => xmpp_ns ('vcard_upd'), name => 'photo', childs => [ $vc->{_avatar_hash} ] } } push @$create_cb, { defns => xmpp_ns ('vcard_upd'), node => { ns => xmpp_ns ('vcard_upd'), name => 'x', ($chlds ? (childs => [ @$chlds ]) : ()), } }; }, ext_after_session_ready => sub { my ($con) = @_; if (not $dont_retrieve_vcard) { $self->retrieve ($con, undef, sub { my ($jid, $vc, $error) = @_; if ($error) { $self->event (retrieve_vcard_error => $error); } # the own vcard was already set by retrieve # this will push out an updated presence $self->_publish_avatar; }); } } ); my $ar = [$con, $rid]; Scalar::Util::weaken $ar->[0]; push @{$self->{hooked}}, $ar; } sub _publish_avatar { my ($self) = @_; for (@{$self->{hooked}}) { if ($_->[0]) { $_->[0]->send_presence () } } } =item B This method returns the vcard for the account connected by C<$con>. This only works if vcard was (successfully) retrieved. If the connection was hoooked up the vcard was automatically retrieved. Alternatively C<$con> can also be a string reprensenting the JID of an account. =cut sub my_vcard { my ($self, $con) = @_; $self->{own_vcards}->{prep_bare_jid (ref ($con) ? $con->jid : $con)} } =item B See also C about the meaning of cache hashes. If no argument is given the current cache is returned. =cut sub cache { my ($self, $cache_hash) = @_; $self->{cache} = $cache_hash if defined $cache_hash; $self->{cache} } sub _store { my ($self, $con, $vcard_cb, $cb) = @_; $con->send_iq ( set => sub { my ($w) = @_; $w->addPrefix (xmpp_ns ('vcard'), ''); $w->startTag ([xmpp_ns ('vcard'), 'vCard']); $vcard_cb->($w); $w->endTag; }, sub { my ($xmlnode, $error) = @_; if ($error) { $cb->($error); } else { $cb->(); } } ); } =item B This method will store your C<$vcard> on the connected server. C<$cb> is called when either an error occured or the storage was successful. If an error occured the first argument is not undefined and contains an L object. C<$con> should be a L or an object from some derived class. C<$vcard> has a datastructure as described below in B. =cut sub store { my ($self, $con, $vcard, $cb) = @_; $self->_store ($con, sub { my ($w) = @_; $self->encode_vcard ($vcard, $w); }, sub { $cb->(@_); }); } sub _retrieve { my ($self, $con, $dest, $cb) = @_; $con->send_iq ( get => { defns => 'vcard', node => { ns => 'vcard', name => 'vCard' } }, sub { my ($xmlnode, $error) = @_; if ($error) { $cb->(undef, undef, $error); } else { my ($vcard) = $xmlnode->find_all ([qw/vcard vCard/]); my $jid = $dest || prep_bare_jid ($con->jid); $vcard = $self->decode_vcard ($vcard); if (prep_bare_jid ($jid) eq prep_bare_jid ($con->jid)) { $self->{own_vcards}->{prep_bare_jid $con->jid} = $vcard; } $self->event (vcard => $jid, $vcard); $cb->($jid, $vcard, $error); } }, (defined $dest ? (to => $dest) : ()) ); } =item B This method will retrieve the vCard for C<$jid> via the connection C<$con>. If C<$jid> is undefined the vCard of yourself is retrieved. The callback C<$cb> is called when an error occured or the vcard was retrieved. The first argument of the callback will be the JID to which the vCard belongs, the second argument is the vCard itself (as described in B below) and the thrid argument is the error, if an error occured (undef otherwise). =cut sub retrieve { my ($self, $con, $dest, $cb) = @_; $self->_retrieve ($con, $dest, sub { my ($jid, $vc, $error) = @_; if ($error) { $cb->(undef, $error); return } else { $cb->($jid, $vc); } }); } sub decode_vcard { my ($self, $vcard) = @_; my $ocard = {}; for my $cn ($vcard->nodes) { if ($cn->nodes) { my $sub = {}; for ($cn->nodes) { $sub->{$_->name} = $_->text } push @{$ocard->{$cn->name}}, $sub; } else { push @{$ocard->{$cn->name}}, $cn->text; } } if (my $p = $ocard->{PHOTO}) { my $first = $p->[0]; if ($first->{BINVAL} ne '') { $ocard->{_avatar} = decode_base64 ($first->{BINVAL}); $ocard->{_avatar_hash} = sha1_hex ($ocard->{_avatar}); $ocard->{_avatar_type} = $first->{TYPE}; } } $ocard } sub encode_vcard { my ($self, $vcardh, $w) = @_; if ($vcardh->{_avatar}) { $vcardh->{PHOTO} = [ { BINVAL => encode_base64 ($vcardh->{_avatar}), TYPE => $vcardh->{_avatar_type} } ]; } for my $ve (keys %$vcardh) { next if substr ($ve, 0, 1) eq '_'; for my $el (@{ref ($vcardh->{$ve}) eq 'ARRAY' ? $vcardh->{$ve} : [$vcardh->{$ve}]}) { if (ref $el) { $w->startTag ([xmpp_ns ('vcard'), $ve]); for (keys %$el) { if ((not defined $el->{$_}) || $el->{$_} eq '') { $w->emptyTag ([xmpp_ns ('vcard'), $_]); } else { $w->startTag ([xmpp_ns ('vcard'), $_]); $w->characters ($el->{$_}); $w->endTag; } } $w->endTag; } elsif ((not defined $el) || $el eq '') { $w->emptyTag ([xmpp_ns ('vcard'), $ve]); } else { $w->startTag ([xmpp_ns ('vcard'), $ve]); $w->characters ($el); $w->endTag; } } } } sub DESTROY { my ($self) = @_; $self->unreg_cb ($self->{cb_id}); for (@{$self->{hooked}}) { $_->[0]->unreg_cb ($_->[1]) if defined $_->[0]; } } =back =head1 VCARD STRUCTURE As there are currently no nice DOM implementations in Perl and I strongly dislike the DOM API in general this module has a simple Perl datastructure without cycles to represent the vCard. First an example: A fetched vCard hash may look like this: { 'URL' => ['http://www.ta-sa.org/'], 'ORG' => [{ 'ORGNAME' => 'nethype GmbH' }], 'N' => [{ 'FAMILY' => 'Redeker' }], 'EMAIL' => ['elmex@ta-sa.org'], 'BDAY' => ['1984-06-01'], 'FN' => ['Robin'], 'ADR' => [ { HOME => undef, 'COUNTRY' => 'Germany' }, { WORK => undef, COUNTRY => 'Germany', LOCALITY => 'Karlsruhe' } ], 'NICKNAME' => ['elmex'], 'ROLE' => ['Programmer'] } The keys represent the toplevel element of a vCard, the values are always array references containig one or more values for the key. If the value is a hash reference again it's value will not be an array reference but either undef or plain values. The values of the toplevel keys are all array references because fields like C may occur multiple times. Consult XEP-0054 for an explanation what these fields mean or contain. There are special fields in this structure for handling avatars: C<_avatar> contains the binary data for the avatar image. C<_avatar_hash> contains the sha1 hexencoded hash of the binary image data. C<_avatar_type> contains the mime type of the avatar. If you want to store the vcard you only have to set C<_avatar> and C<_avatar_type> if you want to store an avatar. =head1 EVENTS The vcard extension will emit these events: =head1 TODO Implement caching, the cache stuff is just a storage hash at the moment. Or maybe drop it completly and let the application handle caching. =over 4 =item retrieve_vcard_error => $iq_error When a vCard retrieval was not successful, this event is emitted. This is neccessary as some retrievals may happen automatically. =item vcard => $jid, $vcard Whenever a vCard is retrieved, either automatically or manually, this event is emitted with the retrieved vCard. =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.55/lib/AnyEvent/XMPP/Ext/OOB.pm0000644000014500017510000001320012066334771020050 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::OOB; use strict; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Ext; our @ISA = qw/AnyEvent::XMPP::Ext/; =head1 NAME AnyEvent::XMPP::Ext::OOB - XEP-0066 Out of Band Data =head1 SYNOPSIS my $con = AnyEvent::XMPP::Connection->new (...); $con->add_extension (my $disco = AnyEvent::XMPP::Ext::Disco->new); $con->add_extension (my $oob = AnyEvent::XMPP::Ext::OOB->new); $disco->enable_feature ($oob->disco_feature); $oob->reg_cb (oob_recv => sub { my ($oob, $con, $node, $url) = @_; if (got ($url)) { $oob->reply_success ($con, $node); } else { $oob->reply_failure ($con, $node, 'not-found'); } }); $oob->send_url ( $con, 'someonewho@wants.an.url.com', "http://nakedgirls.com/marie_021.jpg", "Yaww!!! Hot like SUN!", sub { my ($error) = @_; if ($error) { # then error } else { # everything fine } } ) =head1 DESCRIPTION This module provides a helper abstraction for handling out of band data as specified in XEP-0066. The object that is generated handles out of band data requests to and from others. There is are also some utility function defined to get for example the oob info from an XML element: =head1 FUNCTIONS =over 4 =item B This function extracts the URL and optionally a description field from the XML element in C<$node> (which must be a L). C<$node> must be the XML node which contains the and optionally element (which is eg. a element)! (This method searches both, the jabber:x:oob and jabber:iq:oob namespaces for the and elements). It returns a hash reference which should have following structure: { url => "http://someurl.org/mycoolparty.jpg", desc => "That was a party!", } If nothing was found this method returns nothing (undef). =cut sub url_from_node { my ($node) = @_; my ($url) = $node->find_all ([qw/x_oob url/]); my ($desc) = $node->find_all ([qw/x_oob desc/]); my ($url2) = $node->find_all ([qw/iq_oob url/]); my ($desc2) = $node->find_all ([qw/iq_oob desc/]); $url ||= $url2; $desc ||= $desc2; defined $url ? { url => $url->text, desc => ($desc ? $desc->text : undef) } : () } =back =head1 METHODS =over 4 =item B This is the constructor, it takes no further arguments. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } sub init { my ($self) = @_; $self->reg_cb ( iq_set_request_xml => sub { my ($self, $con, $node, $handled) = @_; for ($node->find_all ([qw/iq_oob query/])) { my $url = url_from_node ($_); $self->event (oob_recv => $con, $node, $url); $$handled = 1; } } ); } sub disco_feature { (xmpp_ns ('x_oob'), xmpp_ns ('iq_oob')) } =item B This method replies to the sender of the oob that the URL was retrieved successfully. C<$con> and C<$node> are the C<$con> and C<$node> arguments of the C event you want to reply to. =cut sub reply_success { my ($self, $con, $node) = @_; $con->reply_iq_result ($node); } =item B This method replies to the sender that either the transfer was rejected or it was not fount. If the transfer was rejectes you have to set C<$type> to 'reject', otherwise C<$type> must be 'not-found'. C<$con> and C<$node> are the C<$con> and C<$node> arguments of the C event you want to reply to. =cut sub reply_failure { my ($self, $con, $node, $type) = @_; if ($type eq 'reject') { $con->reply_iq_error ($node, 'cancel', 'item-not-found'); } else { $con->reply_iq_error ($node, 'modify', 'not-acceptable'); } } =item B This method sends a out of band file transfer request to C<$jid>. C<$url> is the URL that the otherone has to download. C<$desc> is an optional description string (human readable) for the file pointed at by the url and can be undef when you don't want to transmit any description. C<$cb> is a callback that will be called once the transfer is successful. The first argument to the callback will either be undef in case of success or 'reject' when the other side rejected the file or 'not-found' if the other side was unable to download the file. =cut sub send_url { my ($self, $con, $jid, $url, $desc, $cb) = @_; $con->send_iq (set => { defns => iq_oob => node => { ns => iq_oob => name => 'query', childs => [ { ns => iq_oob => name => 'url', childs => [ $url ] }, { ns => iq_oob => name => 'desc', (defined $desc ? (childs => [ $desc ]) : ()) } ] }}, sub { my ($n, $e) = @_; if ($e) { $cb->($e->condition eq 'item-not-found' ? 'not-found' : 'reject') if $cb; } else { $cb->() if $cb; } }, to => $jid); } =back =head1 EVENTS These events can be registered to whith C: =over 4 =item oob_recv => $con, $node, $url This event is generated whenever someone wants to send you a out of band data file. C<$url> is a hash reference like it's returned by C. C<$con> is the L (Or L) the data was received from. C<$node> is the L of the IQ request, you can get the senders JID from the 'from' attribute of it. If you fetched the file successfully you have to call C. If you want to reject the file or couldn't get it call C. =back =cut 1 AnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Ext/DataForm.pm0000644000014500017510000002716012066334771021140 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::DataForm; use strict; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; =head1 NAME AnyEvent::XMPP::Ext::DataForm - XEP-0004 DataForm =head1 SYNOPSIS =head1 DESCRIPTION This module represents a Data Form as specified in XEP-0004. =head1 METHODS =over 4 =item B =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } sub init { my ($self) = @_; $self->{fields} = []; $self->{field_var} = {}; $self->{items} = []; $self->{reported} = []; delete $self->{type}; delete $self->{title}; delete $self->{instructions}; } =item B This method appends a field to the form. C<$field> must have the structure as described in L below. =cut sub append_field { my ($self, $field) = @_; $self->{fields} = [] unless $self->{fields}; $self->{field_var} = {} unless $self->{field_var}; push @{$self->{fields}}, $field; $self->{field_var}->{$field->{var}} = $field if defined $field->{var}; } =item B This method interprets the L object in C<$node> as data form XML node and reads out the fields and all associated information. (C<$node> must be the XML node of the tag). =cut sub _extract_field { my ($field) = @_; my $fo = { label => $field->attr ('label'), var => $field->attr ('var'), type => $field->attr ('type'), }; my ($desc) = $field->find_all ([qw/data_form desc/]); if ($desc) { $fo->{desc} = $desc->text; } if ($field->find_all ([qw/data_form required/])) { $fo->{required} = 1; } my (@vals) = $field->find_all ([qw/data_form value/]); $fo->{values} = []; for (@vals) { push @{$fo->{values}}, $_->text; } my (@opts) = $field->find_all ([qw/data_form option/]); $fo->{options} = []; for my $o (@opts) { my (@v) = $o->find_all ([qw/data_form value/]); my $vals = []; for my $val (@v) { push @$vals, $val->text; } push @{$fo->{options}}, [$o->attr ('label'), $vals]; } $fo } sub from_node { my ($self, $node) = @_; $self->init; my ($title) = $node->find_all ([qw/data_form title/]); my ($instr) = $node->find_all ([qw/data_form instructions/]); $self->{type} = $node->attr ('type'); $self->{title} = $title->text if $title; $self->{instructions} = $instr->text if $instr; for my $field ($node->find_all ([qw/data_form field/])) { my $fo = _extract_field ($field); $self->append_field ($fo); } my ($rep) = $node->find_all ([qw/data_form reported/]); if ($rep) { for my $field ($rep->find_all ([qw/data_form field/])) { my $fo = { label => $field->attr ('label'), var => $field->attr ('var'), type => $field->attr ('type'), }; push @{$self->{reported}}, $fo; } } for my $item ($node->find_all ([qw/data_form item/])) { my $flds = []; for my $field ($item->find_all ([qw/data_form field/])) { my $fo = _extract_field ($field); push @$flds, $fo; } push @{$self->{items}}, $flds; } } =item B This method initializes this form with default answers and other neccessary fields from C<$request_form>, which must be of type L or compatible. The result will be a form with a copy of all fields which are not of type C. The fields will also have the default value copied over. The form type will be set to C. The idea is: this creates a template answer form from C<$request_form>. To strip out the unneccessary fields later you don't need call the C method. =cut sub make_answer_form { my ($self, $reqform) = @_; $self->set_form_type ('submit'); for my $field ($reqform->get_fields) { next if $field->{type} eq 'fixed'; my $fo = { var => $field->{var}, type => $field->{type}, values => [ @{$field->{values}} ], options => [], }; $self->append_field ($fo); } } =item B This method removes all fields that have no values and options. =cut sub clear_empty_fields { my ($self) = @_; my @dead; for ($self->get_fields) { unless (@{$_->{values}} || @{$_->{options}}) { push @dead, $_; } } $self->remove_field ($_) for @dead; } =item B This method removes a field either by it's unique name or by reference. C<$field_or_var> can either be the unique name or the actual field hash reference you get from C or C. =cut sub remove_field { my ($self, $field) = @_; unless (ref $field) { $field = $self->get_field ($field) or return; } @{$self->{fields}} = grep { $_ ne $field } @{$self->{fields}}; if (defined $field->{var}) { delete $self->{field_var}->{$field->{var}}; } } =item B This method sets the type of the form, which must be one of: form, submit, cancel, result =cut sub set_form_type { my ($self, $type) = @_; $self->{type} = $type; } =item B This method returns the type of the form, which is one of the options described in C above or undef if no type was yet set. =cut sub form_type { return $_[0]->{type} } =item B If this is a search result this method returns more than one element here. The returned list consists of fields as described in L, only that they lack values and options. See also the C method. =cut sub get_reported_fields { my ($self) = @_; @{$self->{reported}} } =item B If this form is a search result this method returns the list of items of that search. An item is a array ref of fields (field structure is described in L). This method returns a list of items. =cut sub get_items { my ($self) = @_; @{$self->{items}}; } =item B This method returns a list of fields. Each field has the structure as described in L. =cut sub get_fields { my ($self) = @_; @{$self->{fields}} } =item B Returns the field with the unique field name C<$var> or undef if no such field is in this form. =cut sub get_field { my ($self, $var) = @_; $self->{field_var}->{$var} } =item B This method sets the value of the field with the unique name C<$var>. If the field has supports multiple values all values will be removed and only C<$value> will be added, if C<$value> is undefined the field's value will be deleted. =cut sub set_field_value { my ($self, $var, $val) = @_; my $f = $self->get_field ($var) or return; $f->{values} = defined $val ? [ $val ] : []; } =item B This method adds the C<$value> to the field with the unique name C<$var>. If the field doesn't support multiple values this method has the same effect as C. =cut sub add_field_value { my ($self, $var, $val) = @_; my $f = $self->get_field ($var) or return; if (grep { $f->{type} eq $_ } qw/jid-multi list-multi text-multi/) { push @{$f->{values}}, $val; } else { $self->set_field_value ($var, $val); } } =item B This method converts the form to a data strcuture that you can pass as C argument to the C function which is documented in L. Example call might be: my $node = $form->to_simxml; simxml ($w, defns => $node->{ns}, node => $node); B The returned simxml node has the C field set so that no prefixes are generated for the namespace it is in. =cut sub _field_to_simxml { my ($f) = @_; my $ofa = []; my $ofc = []; my $of = { name => 'field', attrs => $ofa, childs => $ofc }; push @$ofa, (label => $f->{label}) if defined $f->{label}; push @$ofa, (var => $f->{var}) if defined $f->{var}; push @$ofa, (type => $f->{type}) if defined $f->{type}; for (@{$f->{values}}) { push @$ofc, { name => 'value', childs => [ $_ ] } } for (@{$f->{options}}) { my $at = []; my $chlds = []; push @$ofc, { name => 'option', attrs => $at, childs => $chlds }; for (@{$_->[1]}) { push @$chlds, { name => 'value', childs => [ $_ ] } } if (defined $_->[0]) { push @$at, (label => $_->[0]) } } if ($f->{desc}) { push @$ofc, { name => 'desc', childs => [ $f->{desc} ] } } if ($f->{required}) { push @$ofc, { name => 'required' } } $of } sub to_simxml { my ($self) = @_; my $fields = []; my $top = { ns => 'data_form', dns => 'data_form', name => 'x', attrs => [], childs => $fields, }; push @{$top->{attrs}}, ( type => $self->{type} ); if (defined $self->{title}) { push @$fields, { name => 'title', childs => [ $self->{title} ] } } if (defined $self->{instructions}) { push @$fields, { name => 'instructions', childs => [ $self->{instructions} ] } } for my $f ($self->get_fields) { push @$fields, _field_to_simxml ($f); } my $repchld = []; for my $rf ($self->get_reported_fields) { push @$repchld, _field_to_simxml ($rf); } if (@$repchld) { push @$fields, { name => 'reported', childs => $repchld }; } for my $itf ($self->get_items) { my $itfields = []; for my $f (@$itf) { push @$itfields, _field_to_simxml ($f); } push @$fields, { name => 'item', childs => $itfields } } $top } =item B This method returns a string that represents the form. Only for debugging purposes. =cut sub as_debug_string { my ($self) = @_; my $str; $str .= "title: $self->{title}\n" ."instructions: $self->{instructions}\n" ."type: $self->{type}\n"; for my $f ($self->get_fields) { $str .= sprintf "- var : %-50s label: %s\n type: %-10s required: %d\n", $f->{var}, $f->{label}, $f->{type}, $f->{required}; for (@{$f->{values}}) { $str .= sprintf " * val : %s\n", $_ } for (@{$f->{options}}) { $str .= sprintf " * opt lbl: %-50s text: %s\n", @$_ } } $str .= "reported:\n"; for my $f (@{$self->{reported}}) { $str .= sprintf "- var: %-50s label: %-30s type: %-10s %d\n", $f->{var}, $f->{label}, $f->{type}; } $str .= "items:\n"; for my $i (@{$self->{items}}) { $str .= "-" x 60 . "\n"; for my $f (@$i) { $str .= sprintf "- var : %-50s\n", $f->{var}; for (@{$f->{values}}) { $str .= sprintf " * val : %s\n", $_ } for (@{$f->{options}}) { $str .= sprintf " * opt lbl: %-50s text: %s\n", @$_ } } } $str } =back =head1 FIELD STRUCTURE { label => 'field label', type => 'field type', var => '(unique) field name' required => true or false value, values => [ 'value text', ... ], options => [ ['option label', 'option text'], ... ] } For the semantics of all fields please consult XEP 0004. =head1 SEE ALSO XEP 0004 =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.55/lib/AnyEvent/XMPP/Ext/MUC.pm0000644000014500017510000003232712066334771020070 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::MUC; use strict; no warnings; use AnyEvent::XMPP::Util qw/prep_bare_jid bare_jid stringprep_jid cmp_jid/; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Ext; use AnyEvent::XMPP::Ext::MUC::Room; use AnyEvent::XMPP::Ext::MUC::RoomInfo; our @ISA = qw/AnyEvent::XMPP::Ext/; =head1 NAME AnyEvent::XMPP::Ext::MUC - Implements XEP-0045: Multi-User Chat =head1 SYNOPSIS my $con = AnyEvent::XMPP::Connection->new (...); $con->add_extension (my $disco = AnyEvent::XMPP::Ext::Disco->new); $con->add_extension (my $muc = AnyEvent::XMPP::Ext::MUC->new (disco => $disco)); ... =head1 DESCRIPTION This module handles multi user chats and provides new events to catch multi user chat messages. It intercepts messages from the connection so they don't interfere with your other callbacks on the connection. This extension requires the L extension for service discovery. =cut =head1 METHODS =over 4 =item B This is the constructor for a MUC extension object. It takes no further arguments. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { join_timeout => 60, @_ }, $class; $self->{inhibit_forward} = { map { ($_ => 1) } qw/message presence/ }; $self->init; $self } sub disco_feature { xmpp_ns ('muc') } sub init { my ($self) = @_; my $proxy = sub { my ($self, @args) = @_; $self->event (@args); }; $self->{disco}->enable_feature ($self->disco_feature); $self->reg_cb ( join_error => $proxy, subject_change_error => $proxy, message_error => $proxy, ); $self->reg_cb ( ext_before_presence_xml => sub { my ($self, $con, $node) = @_; if (my $room = $self->get_room ($con, $node->attr ('from'))) { $self->stop_event; $room->handle_presence ($node); } }, ext_before_message_xml => sub { my ($self, $con, $node) = @_; if (my $room = $self->get_room ($con, $node->attr ('from'))) { $self->stop_event; $room->handle_message ($node); } }, ext_before_leave => sub { my ($self, $room) = @_; $self->uninstall_room ($room->connection, $room); }, disconnect => sub { my ($self, $con, $h, $p, $msg) = @_; $self->cleanup_rooms ($con, "$h:$p: $msg"); } ); } sub cleanup_rooms { my ($self, $con, $msg) = @_; my $conjid = stringprep_jid $con->jid; for (keys %{$self->{rooms}->{$conjid}}) { my $room = delete $self->{rooms}->{$conjid}->{$_}; $self->event (leave => $room, $room->get_me, "disconnected from server $msg"); } } =item B TODO =cut sub is_conference { my ($self, $con, $jid, $cb) = @_; $self->{disco}->request_info ($con, $jid, undef, sub { my ($disco, $info, $error) = @_; if ($error || !$info->features ()->{xmpp_ns ('muc')}) { $cb->(undef, $error); } else { $cb->($info, undef); } }); } =item B This method sends a information discovery to the C<$jid>, via the connection C<$con>. C<$cb> is called when the information arrives or with an error after the usual IQ timeout. When the C<$jid> was a room C<$cb> is called with the first argument being a L object. If the destination wasn't reachable, the room doesn't exist or some other error happened the first argument will be undefined and the second a L object. =cut sub is_room { my ($self, $con, $jid, $cb) = @_; $self->{disco}->request_info ($con, $jid, undef, sub { my ($disco, $info, $error) = @_; if ($error || !$info->features ()->{xmpp_ns ('muc')}) { $cb->(undef, $error); } else { my $rinfo = AnyEvent::XMPP::Ext::MUC::RoomInfo->new (disco_info => $info); $cb->($rinfo, undef); } }); } =item B This method joins a room. C<$con> should be the L object that is to be used to send the necessary stanzas. C<$jid> should be the bare JID of the room. C<$nick> should be your desired nickname in the room. When you successfully entered the room a C event is emitted. In case you created the room, and it is locked, a C event is emitted. Please look in the C section below for more details about how to handle C rooms. (You won't have to care about locked rooms if you didn't disable the C flag in C<%args>). If an error occurred and we couldn't join the room, the first two arguments are undef and the third is a L object signalling the error. C<%args> hash can contain one of the following keys: =over 4 =item timeout => $timeout_in_secs This is the timeout for joining the room. The default timeout is 60 seconds if the timeout is not specified. =item history => {} Manage MUC-history from XEP-0045 (7.1.16) Hash can contain of the following keys: C, C, C Example: history => {chars => 0} # don't load history history => {stanzas => 3} # load last 3 history elements history => {seconds => 300, chars => 500} # load history in last 5 minutes, but max 500 characters TODO: add C attributes =item create_instant => $bool If you set C<$bool> to a true value we try to establish an instant room on joining if it doesn't already exist. XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX The default for this flag is true! So if you want to create an reserved room with custom creation in the beginning you have to pass a false value as C<$bool>. B If you set C<$bool> to a B value you have to check the C status flag on your own instance of L (provided as the second argument to the callback) to see whether you need to finish room creation! If you don't do this the room B. See also the C and C methods of L. =item password => $password The password for the room. =item nickcollision_cb => $cb If the join to the room results in a nickname collision the C<$cb> will be called with the nickname that collided and the return value will be used as alternate nickname and the join is retried. This function is called I the nickname collides on join, so you should take care of possible endless retries. =back =cut sub join_room { my ($self, $con, $jid, $nick, %args) = @_; unless (exists $args{create_instant}) { $args{create_instant} = 1; } my $timeout = $args{timeout} || $self->{join_timeout}; my $room = $self->install_room ($con, $jid); $room->{locked_cb} = $args{create_instant} ? sub { my ($room) = @_; $room->make_instant (sub { my ($room, $error) = @_; if ($error) { $self->event (join_error => $room, $error); } else { $self->event (enter => $room, $room->get_me); } }); } : undef; $room->{room_join_timer} = AnyEvent->timer (after => $timeout, cb => sub { delete $room->{room_join_timer}; $self->uninstall_room ($con, $room); my $muce = AnyEvent::XMPP::Error::MUC->new ( type => 'join_timeout', text => "Couldn't join room in time, timeout after $timeout\n" ); $self->event (join_error => $room, $muce); }); my $rcb_id; $rcb_id = $self->reg_cb ( join_error => sub { my ($muc, $eroom, $error) = @_; return unless cmp_jid ($eroom->nick_jid, $room->nick_jid); if ($error->type eq 'nickname_in_use' && exists $args{nickcollision_cb}) { $nick = $args{nickcollision_cb}->($nick); $room->send_join ($nick, $args{password}, $args{history}); return; } delete $room->{room_join_timer}; $self->uninstall_room ($con, $room); $muc->unreg_cb ($rcb_id); }, enter => sub { my ($muc, $eroom, $user) = @_; return unless cmp_jid ($eroom->nick_jid, $room->nick_jid); delete $room->{room_join_timer}; $muc->unreg_cb ($rcb_id); } ); $room->send_join ($nick, $args{password}, $args{history}); } sub install_room { my ($self, $con, $room_jid) = @_; my $room = $self->{rooms}->{stringprep_jid $con->jid}->{prep_bare_jid $room_jid} = AnyEvent::XMPP::Ext::MUC::Room->new ( muc => $self, connection => $con, jid => $room_jid ); $room } sub uninstall_room { my ($self, $con, $room) = @_; my $r = delete $self->{rooms}->{stringprep_jid $con->jid}->{prep_bare_jid $room->jid}; delete $r->{muc}; } =item B This returns the L object for the bare part of the C<$jid> if we are joining or have joined such a room. If we are not joined undef is returned. =cut sub get_room { my ($self, $con, $jid) = @_; $self->{rooms}->{stringprep_jid $con->jid}->{prep_bare_jid $jid} } =item B Returns a list of L objects for the connection C<$con>. =cut sub get_rooms { my ($self, $con) = @_; values %{$self->{rooms}->{stringprep_jid $con->jid} || {}} } =back =head1 EVENTS These are the events that are issued by this MUC extension: C<$room> is the L object which the event belongs to. =over 4 =item message => $room, $msg, $is_echo This event is emitted when a message was received from the room. C<$msg> is a L object and C<$is_echo> is true if the message is an echo. B Please note that some conferences send messages already before you have finished joining a room. That means that you might already get a C event for a room that you haven't got an C for event yet. That means that methods like C might return undef. =item subject_change => $room, $msg, $is_echo This event is emitted when a user changes the room subject. C<$msg> is a L object and C<$is_echo> is true if the message is an echo. The room subject is the subject of that C<$msg>. =item subject_change_error => $room, $error If you weren't allowed to change the subject or some other error occurred you will receive this event. C<$error> is a L object. =item error => $room, $error This event is emitted when any error occurred. C<$error> is a L object. =item join_error => $room, $error This event is emitted when a error occurred when joining a room. C<$error> is a L object. =item locked => $room This event is emitted when you disabled the 'create_instant' flag when calling C. It means that you just created a new room, which is locked. You need to configure it before it is unlocked and others can enter. Please consult the methods C, C and C of L for more information about how to configure a room. B You won't get another event when you finished configuring the room, so you maybe want to call this on the C object when you finished configuring the room successfully: $muc->event (enter => $room, $room->get_me); That could be helpful if you want to place some generic stuff in your C event handlers. B If you didn't disable the C flag of C you won't have to care about a C event, as everything will be internally handled for you and you will get an C event if the room is finally setted up. =item enter => $room, $user This event is emitted when we successfully joined the room. C<$user> is a L object which is the user handle for ourself. =item join => $room, $user This event is emitted when a new user joins the room. C<$user> is the L object of that user. =item nick_change => $room, $user, $oldnick, $newnick This event is emitted when a user changed his nickname. C<$user> is the L object of that user. C<$oldnick> is the old nickname and C<$newnick> is the new nickname. =item presence => $room, $user This event is emitted when a user changes it's presence status (eg. affiliation or role, or away status). C<$user> is the L object of that user. =item part => $room, $user This event is emitted when a user leaves the channel. C<$user> is the L of that user, but please note that you shouldn't send any messages to this user anymore. =item leave => $room, $user This event is emitted when we leave the room. C<$user> is your L handle. =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::Ext::MUC AnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Ext/Ping.pm0000644000014500017510000001521412066334771020335 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::Ping; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Util qw/simxml/; use AnyEvent::XMPP::Ext; use strict; our @ISA = qw/AnyEvent::XMPP::Ext/; =head1 NAME AnyEvent::XMPP::Ext::Ping - Implementation of XMPP Ping XEP-0199 =head1 SYNOPSIS use AnyEvent::XMPP::Ext::Ping; my $con = AnyEvent::XMPP::IM::Connection->new (...); $con->add_extension (my $ping = AnyEvent::XMPP::Ext::Ping->new); # this enables auto-timeout of a connection if it didn't answer # within 120 seconds to a ping with a reply $ping->enable_timeout ($con, 120); my $cl = AnyEvent::XMPP::Client->new (...); $cl->add_extension (my $ping = AnyEvent::XMPP::Ext::Ping->new); # this enables auto-timeout of newly created connections $ping->auto_timeout (120); $ping->ping ($con, 'ping_dest@server.tld', sub { my ($time, $error) = @_; if ($error) { # we got an error } # $time is a float (seconds) of the rtt if you got Time::HiRes }); =head1 DESCRIPTION This extension implements XEP-0199: XMPP Ping. It allows you to define a automatic ping timeouter that will disconnect dead connections (which didn't reply to a ping after N seconds). See also the documentation of the C method below. It also allows you to send pings to any XMPP entity you like and will measure the time it took if you got L. =head1 METHODS =over 4 =item B Creates a new ping handle. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } =item B This method enables automatic connection timeout of new connections. It calls C (see below) for every new connection that was connected and emitted a C event. This is useful if you want connections that have this extension automatically timeouted. In particular this is useful with modules like L (see also L above). =cut sub auto_timeout { my ($self, $timeout) = @_; $self->{autotimeout} = $timeout; return if defined $self->{cb_id2}; $self->{cb_id2} = $self->reg_cb ( stream_ready => sub { my ($self, $con) = @_; $self->enable_timeout ($con, \$self->{autotimeout}); }, disconnect => sub { my ($self, $con) = @_; $self->disable_timeout ($con); } ); } =item B This enables a periodical ping on the connection C<$con>. C<$timeout> must be the seconds that the ping intervals last. If the server which is connected via C<$con> didn't respond within C<$timeout> seconds the connection C<$con> will be disconnected. Please note that there already is a basic timeout mechanism for dead TCP connections in L, see also the C configuration variable for a connection there. It then will depend on TCP timeouts to disconnect the connection. Use C and C only if you really feel like you need an explicit timeout for your connections. =cut sub enable_timeout { my ($self, $con, $timeout) = @_; my $rt = $timeout; unless (ref $timeout) { $rt = \$timeout; } $self->_start_cust_timeout ($con, $rt); } sub disable_timeout { my ($self, $con) = @_; delete $self->{cust_timeouts}->{$con}; } sub _start_cust_timeout { my ($self, $con, $rtimeout) = @_; return unless $con->is_connected; $self->{cust_timeouts}->{$con} = AnyEvent->timer (after => $$rtimeout, cb => sub { delete $self->{cust_timeouts}->{$con}; return unless $con->is_connected; $self->ping ($con, undef, sub { my ($t, $e) = @_; if (defined ($e) && $e->condition eq 'client-timeout') { $con->disconnect ("exceeded ping timeout of $$rtimeout seconds"); } else { $self->_start_cust_timeout ($con, $rtimeout) } }, $$rtimeout); }); } sub init { my ($self) = @_; if (eval "require Time::HiRes") { $self->{has_time_hires} = 1; } $self->{cb_id} = $self->reg_cb ( iq_get_request_xml => sub { my ($self, $con, $node, $handled) = @_; if ($self->handle_ping ($con, $node)) { $$handled = 1; } } ); } sub disco_feature { xmpp_ns ('ping') } sub DESTROY { my ($self) = @_; $self->unreg_cb ($self->{cb_id}); $self->unreg_cb ($self->{cb_id2}) if defined $self->{cb_id2}; } sub handle_ping { my ($self, $con, $node) = @_; if (my ($q) = $node->find_all ([qw/ping ping/])) { unless ($self->{ignore_pings}) { $con->reply_iq_result ($node); } return 1; } 0; } =item B This method sends a ping request to C<$dest> via the L in C<$con>. If C<$dest> is undefined the ping will be sent to the connected server. C<$cb> will be called when either the ping timeouts, an error occurs or the ping result was received. C<$timeout> is an optional timeout for the ping request, if C<$timeout> is not given the default IQ timeout for the connection is the relevant timeout. The first argument to C<$cb> will be the seconds of the round trip time for that request (If you have L). If you don't have L installed the first argument will be undef. The second argument to C<$cb> will be either undef if no error occured or a L error object. =cut sub ping { my ($self, $con, $jid, $cb, $timeout) = @_; my $time = 0; if ($self->{has_time_hires}) { $time = [Time::HiRes::gettimeofday ()]; } $con->send_iq ( get => { defns => ping => node => { name => 'ping' } }, sub { my ($n, $e) = @_; my $elap = 0; if ($self->{has_time_hires}) { $elap = Time::HiRes::tv_interval ($time, [Time::HiRes::gettimeofday ()]); } $cb->($elap, $e); }, (defined $jid ? (to => $jid) : ()), (defined $timeout ? (timeout => $timeout) : ()), ); } =item B This method is mostly for testing, it tells this extension to ignore all ping requests and will prevent any response from being sent. =cut sub ignore_pings { my ($self, $enable) = @_; $self->{ignore_pings} = $enable; } =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.55/lib/AnyEvent/XMPP/Ext/MUC/0000755000014500017510000000000012304452270017511 5ustar michaelstaffAnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Ext/MUC/User.pm0000644000014500017510000000652312066334771021005 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::MUC::User; use strict; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::IM::Presence; use AnyEvent::XMPP::Ext::MUC::Message; use AnyEvent::XMPP::Util qw/split_jid/; our @ISA = qw/AnyEvent::XMPP::IM::Presence/; =head1 NAME AnyEvent::XMPP::Ext::MUC::User - User class =head1 SYNOPSIS =head1 DESCRIPTION This module represents a user (occupant) handle for a MUC. This class is derived from L as a user has also a presence within a room. =head1 METHODS =over 4 =item B =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = $class->SUPER::new (@_); $self->init; $self } sub update { my ($self, $node) = @_; $self->SUPER::update ($node); my ($xuser) = $node->find_all ([qw/muc_user x/]); my $from = $node->attr ('from'); my ($room, $srv, $nick) = split_jid ($from); my ($aff, $role, $stati, $jid, $new_nick); $self->{stati} ||= {}; $stati = $self->{stati}; delete $self->{stati}->{'303'}; # nick change if ($xuser) { if (my ($item) = $xuser->find_all ([qw/muc_user item/])) { $aff = $item->attr ('affiliation'); $role = $item->attr ('role'); $jid = $item->attr ('jid'); $new_nick = $item->attr ('nick'); } for ($xuser->find_all ([qw/muc_user status/])) { $stati->{$_->attr ('code')}++; } } $self->{jid} = $from; $self->{nick} = $nick; $self->{affiliation} = $aff; $self->{real_jid} = $jid if defined $jid && $jid ne ''; $self->{role} = $role; if ($self->is_in_nick_change) { $self->{old_nick} = $self->{nick}; $self->{nick} = $new_nick; } } sub init { my ($self) = @_; $self->{connection} = $self->{room}->{muc}->{connection} } =item B The nickname of the MUC user. =cut sub nick { $_[0]->{nick} } =item B The affiliation of the user. =cut sub affiliation { $_[0]->{affiliation} } =item B The role of the user. =cut sub role { $_[0]->{role} } =item B The L this user is in. =cut sub room { $_[0]->{room} } =item B The room local JID of the user. =cut sub in_room_jid { $_[0]->{jid} } =item B The real JID of the user, this might be undef if it is an anonymous room. =cut sub real_jid { $_[0]->{real_jid} } =item B Returns a L object with the to field set to this presence full JID. C<%args> are further arguments to the constructor of the message. =cut sub message_class { 'AnyEvent::XMPP::Ext::MUC::Message' } =item B This method returns true if the user created a room. =cut sub did_create_room { $_[0]->{stati}->{'201'} } sub make_message { my ($self, %args) = @_; $self->message_class ()->new ( room => $self->room, to => $self->jid, %args ); } sub is_in_nick_change { $_[0]->{stati}->{'303'} } sub nick_change_old_nick { $_[0]->{old_nick} } =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.55/lib/AnyEvent/XMPP/Ext/MUC/RoomInfo.pm0000644000014500017510000000322412066334771021612 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::MUC::RoomInfo; use strict; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; =head1 NAME AnyEvent::XMPP::Ext::MUC::RoomInfo - Room information =head1 SYNOPSIS =head1 DESCRIPTION This module represents the room information for a MUC. =head1 METHODS =over 4 =item B =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } sub init { my ($self) = @_; my $info = $self->{disco_info}; my $df; if (my ($xdata) = $info->xml_node ()->find_all ([qw/data_form x/])) { $df = AnyEvent::XMPP::Ext::DataForm->new; $df->from_node ($xdata); } $self->{form} = $df; } =item B This method returns the info discovery object L for the disco query that this roominfo was obtained from. =cut sub disco_info { $_[0]->{disco_info} } =item B Returns the MUC room information as string for debugging. =cut sub as_debug_string { my ($self) = @_; my $info = $self->{disco_info}; my @feats = keys %{$info->features}; my $str = "MUC features for " . $info->jid . "\n"; for (@feats) { if (/^muc_/) { $str .= "- $_\n"; } } if (defined $self->{form}) { $str .= "form:\n"; $str .= $self->{form}->as_debug_string; } $str } =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.55/lib/AnyEvent/XMPP/Ext/MUC/Message.pm0000644000014500017510000000644012066334771021451 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::MUC::Message; use strict; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Util qw/bare_jid res_jid/; use AnyEvent::XMPP::IM::Message; our @ISA = qw/AnyEvent::XMPP::IM::Message/; =head1 NAME AnyEvent::XMPP::Ext::MUC::Message - A room message =head1 SYNOPSIS =head1 DESCRIPTION This message represents a message from a MUC room. It is derived from L. (You can use the methods from that class to access it for example). Also the methods like eg. C return a L. =head1 METHODS =over 4 =item B This constructor takes the same arguments that the constructor for L takes. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = $class->SUPER::new (@_); $self->{connection} = $self->{room}->{connection}; $self } sub from_node { my ($self, $node) = @_; $self->SUPER::from_node ($node); } =item B Returns the chatroom in which' context this message was sent. =cut sub room { $_[0]->{room} } =item B This method send this message. If C<$room> is defined it will set the connection of this message object before it is send. =cut sub send { my ($self, $room) = @_; if ($room) { $self->{room} = $room; $self->{connection} = $self->{room}->{connection}; } my @add; push @add, (subject => $self->{subjects}) if %{$self->{subjects} || {}}; push @add, (thread => $self->thread) if $self->thread; push @add, (from => $self->from) if defined $self->from; $self->{connection}->send_message ( $self->to, $self->type, $self->{create_cbs}, body => $self->{bodies}, @add ); } =item B This method returns a new instance of L. The destination address, connection and type of the returned message object will be set. If C<$msg> is defined and an instance of L the destination address, connection and type of C<$msg> will be changed and this method will not return a new instance of L. If C<$self> is a message of type 'groupchat' the C attribute will be set to the bare JID of the room for the reply. =cut sub make_reply { my ($self, $msg) = @_; unless ($msg) { $msg = $self->new (room => $self->room); } $msg->{connection} = $self->{connection}; $msg->{room} = $self->{room}; if ($self->type eq 'groupchat') { $msg->to (bare_jid $self->from); } else { $msg->to ($self->from); } $msg->type ($self->type); $msg } =item B This method returns the nickname of the source of this message. =cut sub from_nick { my ($self) = @_; res_jid ($self->from) } =item B This method returns true when the message was not directed to the room, but privately to you. =cut sub is_private { my ($self) = @_; $self->type ne 'groupchat' } =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.55/lib/AnyEvent/XMPP/Ext/MUC/Room.pm0000644000014500017510000003563212066334771021006 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::MUC::Room; use strict; no warnings; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Util qw/ bare_jid prep_bare_jid cmp_jid split_jid join_jid is_bare_jid prep_res_jid prep_join_jid resourceprep /; use AnyEvent::XMPP::Ext::MUC::User; use AnyEvent::XMPP::Ext::DataForm; use AnyEvent::XMPP::Error::MUC; use constant { JOIN_SENT => 1, JOINED => 2, LEFT => 3, }; =head1 NAME AnyEvent::XMPP::Ext::MUC::Room - Room class =head1 SYNOPSIS =head1 DESCRIPTION This module represents a room handle for a MUC. =head1 METHODS =over 4 =item B =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { status => LEFT, @_ }, $class; $self->init; $self } sub init { my ($self) = @_; $self->{jid} = bare_jid ($self->{jid}); } sub event { my ($self, $ev, @args) = @_; $self->{muc}->event ($ev, $self, @args); } sub handle_message { my ($self, $node) = @_; my $msg = AnyEvent::XMPP::Ext::MUC::Message->new (room => $self); if ($node->attr ('type') eq 'error') { my $error = AnyEvent::XMPP::Error::MUC->new ( message_node => $node, message => $msg ); if ($error->type eq 'subject_change_forbidden') { $self->event (subject_change_error => $error); } else { $self->event (message_error => $error); } } else { $msg->from_node ($node); my $is_echo = cmp_jid ($msg->from, $self->nick_jid) && $msg->type eq 'groupchat'; if (not (defined $msg->any_body) && defined $msg->any_subject) { # subject change $self->event (subject_change => $msg, $is_echo); return; } $self->event (message => $msg, $is_echo); } } sub handle_presence { my ($self, $node) = @_; my $s = $self->{status}; my $from = $node->attr ('from'); my $type = $node->attr ('type'); my $error; if ($type eq 'error') { $error = AnyEvent::XMPP::Error::Presence->new (node => $node); } my $stati = {}; my $new_nick; if (my ($x) = $node->find_all ([qw/muc_user x/])) { for ($x->find_all ([qw/muc_user status/])) { $stati->{$_->attr ('code')}++; } if (my ($i) = $x->find_all ([qw/muc_user item/])) { $new_nick = $i->attr ('nick'); } } my $nick_change = $stati->{'303'}; if ($s == JOIN_SENT) { if ($error) { my $muce = AnyEvent::XMPP::Error::MUC->new ( presence_error => $error, type => 'presence_error' ); $self->event (join_error => $muce); } else { if (cmp_jid ($from, $self->nick_jid)) { my $user = $self->add_user_xml ($node); $self->{status} = JOINED; $self->{me} = $user; if ($user->did_create_room) { if ($self->{locked_cb}) { (delete $self->{locked_cb})->($self); } else { $self->event ('locked'); } } else { $self->event (enter => $user); } } else { $self->add_user_xml ($node); } } } elsif ($s == JOINED) { # nick changes? if ($error) { my $muce = AnyEvent::XMPP::Error::MUC->new ( presence_error => $error, type => 'presence_error' ); $self->event (error => $muce); } elsif (!$nick_change && $type eq 'unavailable') { if (cmp_jid ($from, $self->nick_jid)) { $self->event ('leave', $self->get_me); $self->we_left_room (); } else { my $nick = prep_res_jid ($from); my $user = delete $self->{users}->{$nick}; if ($user) { $user->update ($node); $self->event (part => $user); } else { warn "User with '$nick' not found in room $self->{jid}!\n"; } } } elsif ($nick_change && $type eq 'unavailable') { my $nick = prep_res_jid ($from); my $nnick = resourceprep ($new_nick); my $user = $self->{users}->{$nnick} = delete $self->{users}->{$nick}; if ($user) { $user->update ($node); $self->event (nick_change_leave => $user, $nick, $new_nick); } else { warn "User with '$nick' not found in room $self->{jid} for nickchange!\n"; } } else { my $nick = prep_res_jid $from; my $pre = $self->{users}->{$nick}; my $in_nick_change = $pre ? $pre->is_in_nick_change : undef; my $user = $self->add_user_xml ($node); if ($pre) { if ($in_nick_change) { $self->event (nick_change => $user, $user->{old_nick}, $user->nick); } else { $self->event (presence => $user); } } else { $self->event (join => $user); } } } } sub we_left_room { my ($self) = @_; $self->{users} = {}; $self->{status} = LEFT; delete $self->{me}; } =item B This method returns the user with the C<$nick> in the room. =cut sub get_user { my ($self, $nick) = @_; $self->{users}->{$nick} } =item B This method returns the L object of yourself in the room. If will return undef if we are not in the room anymore. =cut sub get_me { my ($self) = @_; $self->{me} } =item B This method looks whether a user with the JID C<$jid> exists in the room. That means whether the node and domain part of the JID match the rooms node and domain part, and the resource part of the JID matches a joined nick. =cut sub get_user_jid { my ($self, $jid) = @_; my ($room, $srv, $nick) = split_jid ($jid); return unless prep_join_jid ($room, $srv) eq prep_bare_jid $self->jid; $self->{users}->{$nick} } =item B This method returns the list of occupants as L objects. =cut sub get_users { my ($self) = @_; values %{$self->{users}}; } sub add_user_xml { my ($self, $node) = @_; my $from = $node->attr ('from'); my $nick = prep_res_jid ($from); my $user = $self->{users}->{$nick}; unless ($user) { $user = $self->{users}->{$nick} = AnyEvent::XMPP::Ext::MUC::User->new (room => $self); } $user->update ($node); $user } sub _join_jid_nick { my ($jid, $nick) = @_; my ($node, $host) = split_jid $jid; join_jid ($node, $host, $nick); } sub check_online { my ($self) = @_; unless ($self->is_connected) { warn "room $self not connected anymore!"; return 0; } 1 } sub send_join { my ($self, $nick, $password, $history) = @_; $self->check_online or return; $self->{nick_jid} = _join_jid_nick ($self->{jid}, $nick); $self->{status} = JOIN_SENT; my @chlds; if (defined $password) { push @chlds, { name => 'password', childs => [ $password ] }; } if (defined $history) { my $h; push @{$h->{attrs}}, ('maxchars', $history->{chars}) if defined $history->{chars}; push @{$h->{attrs}}, ('maxstanzas', $history->{stanzas}) if defined $history->{stanzas}; push @{$h->{attrs}}, ('seconds', $history->{seconds}) if defined $history->{seconds}; if (defined $h->{attrs}) { $h->{name} = 'history'; push @chlds, $h; } } my $con = $self->{connection}; $con->send_presence (undef, { defns => 'muc', node => { ns => 'muc', name => 'x', childs => [ @chlds ] } }, to => $self->{nick_jid}); } =item B If you just created a room you can create an instant room with this method instead of going through room configuration for a reserved room. If you want to create a reserved room instead don't forget to unset the C argument of the C method of L! See also the C method below for the reserved room config. C<$cb> is the callback that will be called when the instant room creation is finished. If successful the first argument will be this room object (C<$self>), if unsuccessful the first argument will be undef and the second will be a L object. =cut sub make_instant { my ($self, $cb) = @_; $self->check_online or return; my $df = AnyEvent::XMPP::Ext::DataForm->new; $df->set_form_type ('submit'); my $sxl = $df->to_simxml; $self->{connection}->send_iq ( set => { defns => 'muc_owner', node => { name => 'query', childs => [ $sxl ] } }, sub { my ($n, $e) = @_; if ($e) { $cb->(undef, $e); } else { $cb->($self, undef); } }, to => $self->jid ); } =item B This method requests the room configuration. When the configuration form or an error arrives C<$cb> will be called. The first argument to the callback will be a L with the room configuration form or undef in case of an error. The second argument will be a L error object if an error occurred or undef if no error occurred. If you made an answer form you can send it via the C method below. Here is an example: $room->request_configuration (sub { my ($form, $err) = @_; $form or return; my $af = AnyEvent::XMPP::Ext::DataForm->new; $af->make_answer_form ($form); $af->set_field_value ('muc#roomconfig_maxusers', 20); $af->clear_empty_fields; $roomhdl->send_configuration ($af, sub { # ... }); }); =cut sub request_configuration { my ($self, $cb) = @_; $self->check_online or return; $self->{connection}->send_iq ( get => { defns => 'muc_owner', node => { name => 'query' } }, sub { my ($n, $e) = @_; if ($n) { if (my ($x) = $n->find_all ([qw/muc_owner query/], [qw/data_form x/])) { my $form = AnyEvent::XMPP::Ext::DataForm->new; $form->from_node ($x); $cb->($form, undef); } else { $e = AnyEvent::XMPP::Error::MUC->new ( type => 'no_config_form', text => "The room didn't provide a configuration form" ); $cb->(undef, $e); } } else { $cb->(undef, $e); } }, to => $self->jid ); } =item C This method sends the answer form to a configuration request to the room. C<$answer_form> should be a L object containig the answer form with the changed configuration. The first argument of C<$cb> will be a true value if the configuration change was successful. The second argument of C<$cb> will be a C object if the configuration change was not successful. =cut sub send_configuration { my ($self, $form, $cb) = @_; $self->check_online or return; $self->{connection}->send_iq ( set => { defns => 'muc_owner', node => { name => 'query', childs => [ $form->to_simxml ]} }, sub { my ($n, $e) = @_; if ($e) { $cb->(undef, $e); } else { $cb->(1, undef); } }, to => $self->jid ); } sub message_class { 'AnyEvent::XMPP::Ext::MUC::Message' } =item B This method constructs a L with a connection to this room. C<%args> are further arguments for the constructor of L. The default C argument for the message is the room and the C will be 'groupchat'. =cut sub make_message { my ($self, %args) = @_; $self->message_class ()->new ( room => $self, to => $self->jid, type => 'groupchat', %args ) } =item B This lets you part the room, C<$msg> is an optional part message and can be undef if no custom message should be generated. C<$cb> is called when we successfully left the room or after C<$timeout> seconds. The default for C<$timeout> is 60. The first argument to the call of C<$cb> will be undef if we successfully parted, or a true value when the timeout hit. Even if we timeout we consider ourself parted (and a 'leave' event is generated). =cut sub send_part { my ($self, $msg, $cb, $timeout) = @_; $self->check_online or return; $timeout ||= 60; my $con = $self->{connection}; my $timeouted = 0; if ($cb) { $self->{_part_timeout} = AnyEvent->timer (after => $timeout, cb => sub { delete $self->{_part_timeout}; $timeouted = 1; $self->event ('leave', $self->get_me); }); $self->{muc}->reg_cb (ext_after_leave => sub { my ($muc, $room) = @_; return unless cmp_jid ($room->nick_jid, $self->nick_jid); delete $self->{_part_timeout}; $cb->($timeouted) if $cb; $muc->unreg_me; }); } $con->send_presence ( 'unavailable', undef, (defined $msg ? (status => $msg) : ()), to => $self->{nick_jid} ); } =item B Returns a list of L objects which are in this room. =cut sub users { my ($self) = @_; values %{$self->{users}} } =item B Returns the bare JID of this room. =cut sub jid { $_[0]->{jid} } =item B Returns the full JID of yourself in the room. =cut sub nick_jid { $_[0]->{nick_jid} } =item B Returns true if this room is still connected (but maybe not joined (yet)). =cut sub is_connected { my ($self) = @_; $self->{muc} && $self->{connection} && $self->{connection}->is_connected } =item B If the room is still joined this method will return the connection on which the room is connected. =cut sub connection { my ($self) = @_; $self->{connection} } =item B Returns true if this room is still joined (and connected). =cut sub is_joined { my ($self) = @_; $self->is_connected && $self->{status} == JOINED } =item B This method lets you change your nickname in this room. =cut sub change_nick { my ($self, $newnick) = @_; my ($room, $srv) = split_jid $self->jid; $self->{connection}->send_presence ( undef, undef, to => join_jid ($room, $srv, $newnick) ); } =item B This methods changes the subject of the room. =cut sub change_subject { my ($self, $newsubject) = @_; my $msg = $self->make_message (subject => $newsubject); $msg->send; } =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.55/lib/AnyEvent/XMPP/Ext/Disco.pm0000644000014500017510000002213712066334771020503 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::Disco; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Util qw/simxml/; use AnyEvent::XMPP::Ext::Disco::Items; use AnyEvent::XMPP::Ext::Disco::Info; use AnyEvent::XMPP::Ext; use strict; our @ISA = qw/AnyEvent::XMPP::Ext/; =head1 NAME AnyEvent::XMPP::Ext::Disco - Service discovery manager class for XEP-0030 =head1 SYNOPSIS use AnyEvent::XMPP::Ext::Disco; my $con = AnyEvent::XMPP::IM::Connection->new (...); $con->add_extension (my $disco = AnyEvent::XMPP::Ext::Disco->new); $disco->request_items ($con, 'romeo@montague.net', undef, sub { my ($disco, $items, $error) = @_; if ($error) { print "ERROR:" . $error->string . "\n" } else { ... do something with the $items ... } } ); =head1 DESCRIPTION This module represents a service discovery manager class. You make instances of this class and get a handle to send discovery requests like described in XEP-0030. It also allows you to setup a disco-info/items tree that others can walk and also lets you publish disco information. This class is derived from L and can be added as extension to objects that implement the L interface or derive from it. =head1 METHODS =over 4 =item B Creates a new disco handle. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } sub init { my ($self) = @_; $self->set_identity (client => console => 'AnyEvent::XMPP'); $self->enable_feature (xmpp_ns ('disco_info')); $self->enable_feature (xmpp_ns ('disco_items')); # and features supported by AnyEvent::XMPP in general: $self->enable_feature (AnyEvent::XMPP::Ext::disco_feature_standard ()); $self->{cb_id} = $self->reg_cb ( iq_get_request_xml => sub { my ($self, $con, $node, $handled) = @_; if ($self->handle_disco_query ($con, $node)) { $$handled = 1; } } ); } =item B This sets the identity of the top info node. C<$name> is optional and can be undef. Please note that C<$name> will overwrite all previous set names! If C<$name> is undefined then no previous set name is overwritten. For a list of valid identites look at: http://www.xmpp.org/registrar/disco-categories.html Valid identity C<$type>s for C<$category = "client"> may be: bot console handheld pc phone web =cut sub set_identity { my ($self, $category, $type, $name) = @_; $self->{iden_name} = $name; $self->{iden}->{$category}->{$type} = 1; } =item B This function removes the identity C<$category> and C<$type>. =cut sub unset_identity { my ($self, $category, $type) = @_; delete $self->{iden}->{$category}->{$type}; } =item B This method enables the feature C<$uri>, where C<$uri> should be one of the values from the B column on: http://www.xmpp.org/registrar/disco-features.html These features are enabled by default: http://jabber.org/protocol/disco#info http://jabber.org/protocol/disco#items You can pass also a list of features you want to enable to C! =cut sub enable_feature { my ($self, @feature) = @_; $self->{feat}->{$_} = 1 for @feature; } =item B This method enables the feature C<$uri>, where C<$uri> should be one of the values from the B column on: http://www.xmpp.org/registrar/disco-features.html You can pass also a list of features you want to disable to C! =cut sub disable_feature { my ($self, @feature) = @_; delete $self->{feat}->{$_} for @feature; } sub write_feature { my ($self, $w, $var) = @_; $w->emptyTag ([xmpp_ns ('disco_info'), 'feature'], var => $var); } sub write_identity { my ($self, $w, $cat, $type, $name) = @_; $w->emptyTag ([xmpp_ns ('disco_info'), 'identity'], category => $cat, type => $type, (defined $name ? (name => $name) : ()) ); } sub handle_disco_query { my ($self, $con, $node) = @_; my $q; if (($q) = $node->find_all ([qw/disco_info query/])) { $con->reply_iq_result ( $node, sub { my ($w) = @_; if ($q->attr ('node')) { simxml ($w, defns => 'disco_info', node => { ns => 'disco_info', name => 'query', attrs => [ node => $q->attr ('node') ] }); } else { $w->addPrefix (xmpp_ns ('disco_info'), ''); $w->startTag ([xmpp_ns ('disco_info'), 'query']); for my $cat (keys %{$self->{iden}}) { for my $type (keys %{$self->{iden}->{$cat}}) { $self->write_identity ($w, $cat, $type, $self->{iden_name} ); } } for (sort grep { $self->{feat}->{$_} } keys %{$self->{feat}}) { $self->write_feature ($w, $_); } $w->endTag; } } ); return 1 } elsif (($q) = $node->find_all ([qw/disco_items query/])) { $con->reply_iq_result ( $node, sub { my ($w) = @_; if ($q->attr ('node')) { simxml ($w, defns => 'disco_items', node => { ns => 'disco_items', name => 'query', attrs => [ node => $q->attr ('node') ] }); } else { simxml ($w, defns => 'disco_items', node => { ns => 'disco_items', name => 'query' }); } } ); return 1 } 0 } sub DESTROY { my ($self) = @_; $self->unreg_cb ($self->{cb_id}) } =item B This method does send a items request to the JID entity C<$from>. C<$node> is the optional node to send the request to, which can be undef. C<$con> must be an instance of L or a subclass of it. The callback C<$cb> will be called when the request returns with 3 arguments: the disco handle, an L object (or undef) and an L object when an error occured and no items were received. The timeout of the request is the IQ timeout of the connection C<$con>. $disco->request_items ($con, 'a@b.com', undef, sub { my ($disco, $items, $error) = @_; die $error->string if $error; # do something with the items here ;_) }); =cut sub request_items { my ($self, $con, $dest, $node, $cb) = @_; $con->send_iq ( get => sub { my ($w) = @_; $w->addPrefix (xmpp_ns ('disco_items'), ''); $w->emptyTag ([xmpp_ns ('disco_items'), 'query'], (defined $node ? (node => $node) : ()) ); }, sub { my ($xmlnode, $error) = @_; my $items; if ($xmlnode) { my (@query) = $xmlnode->find_all ([qw/disco_items query/]); $items = AnyEvent::XMPP::Ext::Disco::Items->new ( jid => $dest, node => $node, xmlnode => $query[0] ) } $cb->($self, $items, $error) }, to => $dest ); } =item B This method does send a info request to the JID entity C<$from>. C<$node> is the optional node to send the request to, which can be undef. C<$con> must be an instance of L or a subclass of it. The callback C<$cb> will be called when the request returns with 3 arguments: the disco handle, an L object (or undef) and an L object when an error occured and no items were received. The timeout of the request is the IQ timeout of the connection C<$con>. $disco->request_info ($con, 'a@b.com', undef, sub { my ($disco, $info, $error) = @_; die $error->string if $error; # do something with info here ;_) }); =cut sub request_info { my ($self, $con, $dest, $node, $cb) = @_; $con->send_iq ( get => sub { my ($w) = @_; $w->addPrefix (xmpp_ns ('disco_info'), ''); $w->emptyTag ([xmpp_ns ('disco_info'), 'query'], (defined $node ? (node => $node) : ()) ); }, sub { my ($xmlnode, $error) = @_; my $info; if ($xmlnode) { my (@query) = $xmlnode->find_all ([qw/disco_info query/]); $info = AnyEvent::XMPP::Ext::Disco::Info->new ( jid => $dest, node => $node, xmlnode => $query[0] ) } $cb->($self, $info, $error) }, to => $dest ); } =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.55/lib/AnyEvent/XMPP/Ext/Disco/0000755000014500017510000000000012304452270020126 5ustar michaelstaffAnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Ext/Disco/Info.pm0000644000014500017510000000542512066334771021377 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::Disco::Info; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use strict; =head1 NAME AnyEvent::XMPP::Ext::Disco::Info - Service discovery info =head1 SYNOPSIS =head1 DESCRIPTION This class represents the result of a disco info request sent by a C handler. =head1 METHODS =over 4 =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } =item B Returns the L object of the IQ query. =cut sub xml_node { my ($self) = @_; $self->{xmlnode} } =item B Returns the JID these items belong to. =cut sub jid { $_[0]->{jid} } =item B Returns the node these items belong to (may be undef). =cut sub node { $_[0]->{node} } sub init { my ($self) = @_; my $node = $self->{xmlnode}; return unless $node; my (@ids) = $node->find_all ([qw/disco_info identity/]); for (@ids) { push @{$self->{identities}}, { category => $_->attr ('category'), type => $_->attr ('type'), name => $_->attr ('name'), xml_node => $_, }; } my (@fs) = $node->find_all ([qw/disco_info feature/]); $self->{features}->{$_->attr ('var')} = $_ for @fs; } =item B Returns a list of hashrefs which contain following keys: category, type, name, xml_node C is the category of the identity. C is the type of the identity. C is the human readable name of the identity and might be undef. C is the L object of the node. C and C may be one of those defined on: http://www.xmpp.org/registrar/disco-categories.html =cut sub identities { my ($self) = @_; @{$self->{identities}} } =item B Returns a hashref of key/value pairs where the key is the feature name as listed on: http://www.xmpp.org/registrar/disco-features.html and the value is a L object for the node. =cut sub features { $_[0]->{features} || {} } =item B Prints the information of this Info object to stdout. =cut sub debug_dump { my ($self) = @_; printf "INFO FOR %s (%s):\n", $self->jid, $self->node; for ($self->identities) { printf " ID : %20s/%-10s (%s)\n", $_->{category}, $_->{type}, $_->{name} } for (sort keys %{$self->features}) { printf " FEATURE: %s\n", $_; } print "END ITEMS\n"; } =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.55/lib/AnyEvent/XMPP/Ext/Disco/Items.pm0000644000014500017510000000423212066334771021560 0ustar michaelstaffpackage AnyEvent::XMPP::Ext::Disco::Items; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use strict; =head1 NAME AnyEvent::XMPP::Ext::Disco::Items - Service discovery items =head1 SYNOPSIS =head1 DESCRIPTION This class represents the result of a disco items request sent by a C handler. =head1 METHODS =over 4 =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = bless { @_ }, $class; $self->init; $self } =item B Returns the L object of the IQ query. =cut sub xml_node { my ($self) = @_; $self->{xmlnode} } sub init { my ($self) = @_; my $node = $self->{xmlnode}; return unless $node; my (@items) = $node->find_all ([qw/disco_items item/]); for (@items) { push @{$self->{items}}, { jid => $_->attr ('jid'), name => $_->attr ('name'), node => $_->attr ('node'), xml_node => $_, }; } } =item B Returns the JID these items belong to. =cut sub jid { $_[0]->{jid} } =item B Returns the node these items belong to (may be undef). =cut sub node { $_[0]->{node} } =item B Returns a list of hashreferences which contain following keys: jid, name, node and xml_node C contains the JID of the item. C contains the name of the item and might be undef. C contains the node id of the item and might be undef. C contains the L object of the item for further analyses. =cut sub items { my ($self) = @_; @{$self->{items}} } =item B Prints these items to stdout for debugging. =cut sub debug_dump { my ($self) = @_; printf "ITEMS FOR %s (%s):\n", $self->jid, $self->node; for ($self->items) { printf " - %-40s (%30s): %s\n", $_->{jid}, $_->{node}, $_->{name} } print "END ITEMS\n"; } =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.55/lib/AnyEvent/XMPP/Error/0000755000014500017510000000000012304452270017416 5ustar michaelstaffAnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Error/Stream.pm0000644000014500017510000000522112066334771021221 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.55/lib/AnyEvent/XMPP/Error/Exception.pm0000644000014500017510000000173512066334771021732 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.55/lib/AnyEvent/XMPP/Error/Message.pm0000644000014500017510000000137312066334771021356 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.55/lib/AnyEvent/XMPP/Error/IQAuth.pm0000644000014500017510000000200612066334771021117 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.55/lib/AnyEvent/XMPP/Error/Stanza.pm0000644000014500017510000000775512066334771021244 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.55/lib/AnyEvent/XMPP/Error/Parser.pm0000644000014500017510000000166412066334771021231 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.55/lib/AnyEvent/XMPP/Error/Register.pm0000644000014500017510000000205712066334771021556 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.55/lib/AnyEvent/XMPP/Error/MUC.pm0000644000014500017510000001056512066334771020421 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.55/lib/AnyEvent/XMPP/Error/Presence.pm0000644000014500017510000000136212066334771021534 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.55/lib/AnyEvent/XMPP/Error/IQ.pm0000644000014500017510000000216612066334771020304 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.55/lib/AnyEvent/XMPP/Error/SASL.pm0000644000014500017510000000234512066334771020534 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.55/lib/AnyEvent/XMPP/TestClient.pm0000644000014500017510000002107712066334771020762 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.55/lib/AnyEvent/XMPP/Node.pm0000644000014500017510000001537312066334771017573 0ustar michaelstaffpackage AnyEvent::XMPP::Node; use strict; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use constant { NS => 0, NAME => 1, ATTRS => 2, TEXT => 3, NODES => 4, PARSER => 5, RAW => 6 }; use constant { NNODE => 0, NTEXT => 1, NRAW => 2, }; =head1 NAME AnyEvent::XMPP::Node - XML node tree helper for the parser. =head1 SYNOPSIS use AnyEvent::XMPP::Node; ... =head1 DESCRIPTION This class represens a XML node. L should usually not require messing with the parse tree, but sometimes it is neccessary. If you experience any need for messing with these and feel L should rather take care of it drop me a mail, feature request or most preferably a patch! Every L has a namespace, attributes, text and child nodes. You can access these with the following methods: =head1 METHODS =over 4 =item B Creates a new AnyEvent::XMPP::Node object with the node tag name C<$el> in the namespace URI C<$ns> and the attributes C<$attrs>. The C<$parser> must be the instance of C which generated this node. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = []; $self->[0] = $_[0]; $self->[1] = $_[1]; $self->[2] = $_[2]; $self->[5] = $_[3]; $self->[6] = ''; bless $self, $class; return $self } =item B The tag name of this node. =cut sub name { $_[0]->[NAME] } =item B Returns the namespace URI of this node. =cut sub namespace { $_[0]->[NS] } =item B Returns true whether the current element matches the tag name C<$name> in the namespaces pointed at by C<$namespace_or_alias>. You can either pass an alias that was defined in L or pass an namespace URI in C<$namespace_or_alias>. If no alias with the name C<$namespace_or_alias> was found in L it will be interpreted as namespace URI. The first argument to eq can also be another L instance. =cut sub eq { my ($self, $n, $name) = @_; if (ref $n) { return $self->[PARSER]->nseq ($n->namespace, $n->name, $self->name); } else { my $ns = xmpp_ns ($n); return $self->[PARSER]->nseq (($ns ? $ns : $n), $name, $self->name); } } =item B This method return true if the namespace of this instance of L matches the namespace described by C<$namespace_or_alias> or the namespace of the C<$node> which has to be another L instance. See C for the meaning of C<$namespace_or_alias>. =cut sub eq_ns { my ($self, $n) = @_; if (ref $n) { return ($n->namespace eq $self->namespace); } else { my $ns = xmpp_ns ($n); $ns ||= $n; return ($ns eq $self->namespace); } } =item B Returns the contents of the C<$name> attribute. =cut sub attr { $_[0]->[ATTRS]->{$_[1]}; } =item B Adds a sub-node to the current node. =cut sub add_node { my ($self, $node) = @_; push @{$self->[NODES]}, [NNODE, $node]; } =item B Returns a list of sub nodes. =cut sub nodes { map { $_->[1] } grep { $_->[0] == NNODE } @{$_[0]->[NODES] || []}; } =item B Adds character data to the current node. =cut sub add_text { my ($self, $text) = @_; push @{$self->[NODES]}, [NTEXT, $text]; } =item B Returns the text for this node. =cut sub text { join '', map $_->[1], grep { $_->[0] == NTEXT } @{$_[0]->[NODES] || []} } =item B This method does a recursive descent through the sub-nodes and fetches all nodes that match the last element of C<@path>. The elements of C<@path> consist of a array reference to an array with two elements: the namespace key known by the C<$parser> and the tagname we search for. =cut sub find_all { my ($self, @path) = @_; my $cur = shift @path; my @ret; for my $n ($self->nodes) { if ($n->eq (@$cur)) { if (@path) { push @ret, $n->find_all (@path); } else { push @ret, $n; } } } @ret } =item B This writes the current node out to the L object in C<$writer>. =cut sub write_on { my ($self, $w) = @_; $w->raw ($self->as_string); } =item B This method returns the original character representation of this XML element (and it's children nodes). Please note that the string is a unicode string, meaning: to get octets use: my $octets = encode ('UTF-8', $node->as_string); Now you can roll stunts like this: my $libxml = XML::LibXML->new; my $doc = $libxml->parse_string (encode ('UTF-8', $node->as_string ())); (You can use your favorite XML parser :) =cut sub as_string { my ($self) = @_; join '', map { $_->[0] == NRAW ? $_->[1] : $_->[1]->as_string } grep { $_->[0] != NTEXT } @{$self->[NODES] || []}; } =item B This method is called by the parser to store original strings of this element. =cut sub append_raw { my ($self, $str) = @_; push @{$self->[NODES]}, [NRAW, $str]; } =item B This method takes anything that can receive SAX events. See also L or L or L. With this you can convert this node to any DOM level 2 structure you want: my $builder = XML::LibXML::SAX::Builder->new; $node->to_sax_events ($builder); my $dom = $builder->result; print "Canonized: " . $dom->toStringC14N . "\n"; =cut sub to_sax_events { my ($self, $handler) = @_; my $doc = { Parent => undef }; $handler->start_document ($doc); $self->_to_sax_events ($handler); $handler->end_document ($doc); } sub _to_sax_events { my ($self, $handler) = @_; $handler->start_element ({ NamespaceURI => $self->namespace, Name => $self->name, Attributes => { map { ($_ => { Name => $_, Value => $self->[ATTRS]->{$_} }) } keys %{$self->[ATTRS]} } }); for (@{$self->[NODES]}) { if ($_->[0] == NTEXT) { $handler->characters ($_->[1]); } elsif ($_->[0] == NNODE) { $_->[1]->_to_sax_events ($handler); } } $handler->end_element ({ NamespaceURI => $self->namespace, Name => $self->name, }); } =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.55/lib/AnyEvent/XMPP/Connection.pm0000644000014500017510000011315412273241530020767 0ustar michaelstaffpackage AnyEvent::XMPP::Connection; use strict; use AnyEvent; use AnyEvent::XMPP::Parser; use AnyEvent::XMPP::Writer; use AnyEvent::XMPP::Util qw/split_jid join_jid simxml/; use AnyEvent::XMPP::SimpleConnection; use AnyEvent::XMPP::Namespaces qw/xmpp_ns/; use AnyEvent::XMPP::Extendable; use AnyEvent::XMPP::Error; use Object::Event; use Digest::SHA qw/sha1_hex/; use Encode; our @ISA = qw/AnyEvent::XMPP::SimpleConnection Object::Event AnyEvent::XMPP::Extendable/; =head1 NAME AnyEvent::XMPP::Connection - XML stream that implements the XMPP RFC 3920. =head1 SYNOPSIS use AnyEvent::XMPP::Connection; my $con = AnyEvent::XMPP::Connection->new ( username => "abc", domain => "jabber.org", resource => "AnyEvent::XMPP" ); $con->reg_cb (stream_ready => sub { print "XMPP stream ready!\n" }); $con->connect; # will do non-blocking connect =head1 DESCRIPTION This module represents a XMPP stream as described in RFC 3920. You can issue the basic XMPP XML stanzas with methods like C, C and C. And receive events with the C event framework from the connection. If you need instant messaging stuff please take a look at C. =head1 METHODS =over 4 =item B Following arguments can be passed in C<%args>: =over 4 =item language => $tag This should be the language of the human readable contents that will be transmitted over the stream. The default will be 'en'. Please look in RFC 3066 how C<$tag> should look like. =item jid => $jid This can be used to set the settings C, C (and optionally C) from a C<$jid>. =item username => $username This is your C<$username> (the userpart in the JID); Note: You have to take care that the stringprep profile for nodes can be applied at: C<$username>. Otherwise the server might signal an error. See L for utility functions to check this. B This field has no effect if C is given! =item domain => $domain If you didn't provide a C (see above) you have to set the C which you want to connect as (see above) and the C<$domain> to connect to. B This field has no effect if C is given! =item resource => $resource If this argument is given C<$resource> will be passed as desired resource on resource binding. Note: You have to take care that the stringprep profile for resources can be applied at: C<$resource>. Otherwise the server might signal an error. See L for utility functions to check this. =item host => $host This parameter specifies the hostname where we are going to connect to. The default for this is the C of the C. B To disable DNS SRV lookup you need to specify the port B yourself. See C below. =item use_host_as_sasl_hostname => $bool This is a special parameter for people who might want to use GSSAPI SASL mechanism. It will cause the value of the C parameter (see above) to be passed to the SASL mechanisms, instead of the C of the JID. This flag is provided until support for XEP 0233 is deployed, which will fix the hostname issue w.r.t. GSSAPI SASL. =item port => $port This is optional, the default value for C<$port> is 'xmpp-client=5222', which will used as C<$service> argument to C of L. B If you specify the port number here (instead of 'xmpp-client=5222'), B DNS SRV lookup will be done when connecting. =item connect_timeout => $timeout This sets the connection timeout. If the socket connect takes too long a C event will be generated with an appropriate error message. If this argument is not given no timeout is installed for the connects. =item password => $password This is the password for the C above. =item disable_ssl => $bool If C<$bool> is true no SSL will be used. =item old_style_ssl => $bool If C<$bool> is true the TLS handshake will be initiated when the TCP connection was established. This is useful if you have to connect to an old Jabber server, with old-style SSL connections on port 5223. But that practice has been discouraged in XMPP, and a TLS handshake is done after the XML stream has been established. Only use this option if you know what you are doing. =item disable_sasl => $bool If C<$bool> is true SASL will NOT be used to authenticate with the server, even if it advertises SASL through stream features. Alternative authentication methods will be used, such as IQ Auth (XEP-0078) if the server offers it. =item disable_iq_auth => $bool This disables the use of IQ Auth (XEP-0078) for authentication, you might want to exclude it because it's deprecated and insecure. (However, I want to reach a maximum in compatibility with L so I'm not disabling this by default. See also C below. =item anal_iq_auth => $bool This enables the anal iq auth mechanism that will first look in the stream features before trying to start iq authentication. Yes, servers don't always advertise what they can. I only implemented this option for my test suite. =item disable_old_jabber_authentication => $bool If C<$bool> is a true value, then the B old style authentication method with B old jabber server won't be used when a start tag from the server without version attribute is received. The B old style authentication method is per default enabled to ensure maximum compatibility with old jabber implementations. The old method works as follows: When a start tag is received from the server with no 'version' attribute IQ Auth (XEP-0078) will be initiated to authenticate with the server. Please note that the old authentication method will fail if C is true. =item stream_version_override => $version B Only use if you B know what you are doing! This will override the stream version which is sent in the XMPP stream initiation element. This is currently only used by the tests which set C<$version> to '0.9' for testing IQ authentication with ejabberd. =item whitespace_ping_interval => $interval This will set the whitespace ping interval (in seconds). The default interval are 60 seconds. You can disable the whitespace ping by setting C<$interval> to 0. =back =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = $class->SUPER::new ( language => 'en', stream_namespace => 'client', whitespace_ping_interval => 60, @_ ); $self->{parser} = new AnyEvent::XMPP::Parser; $self->{writer} = AnyEvent::XMPP::Writer->new ( write_cb => sub { $self->write_data ($_[0]) }, send_iq_cb => sub { my @cb; $self->event (send_iq_hook => (@_, \@cb)); return @cb }, send_msg_cb => sub { my @cb; $self->event (send_message_hook => (@_, \@cb)); return @cb }, send_pres_cb => sub { my @cb; $self->event (send_presence_hook => (@_, \@cb)); return @cb }, ); $self->{parser}->set_stanza_cb (sub { eval { $self->handle_stanza (@_); }; if ($@) { $self->event (error => AnyEvent::XMPP::Error::Exception->new ( exception => $@, context => 'stanza handling' ) ); } }); $self->{parser}->set_error_cb (sub { my ($ex, $data, $type) = @_; if ($type eq 'xml') { my $pe = AnyEvent::XMPP::Error::Parser->new (exception => $_[0], data => $_[1]); $self->event (xml_parser_error => $pe); $self->disconnect ("xml error: $_[0], $_[1]"); } else { my $pe = AnyEvent::XMPP::Error->new ( text => "uncaught exception in stanza handling: $ex" ); $self->event (uncaught_exception_error => $pe); $self->disconnect ($pe->string); } }); $self->{parser}->set_stream_cb (sub { $self->{stream_id} = $_[0]->attr ('id'); # This is some very bad "hack" for _very_ old jabber # servers to work with AnyEvent::XMPP if (not defined $_[0]->attr ('version')) { $self->start_old_style_authentication if (not $self->{disable_iq_auth}) && (not $self->{disable_old_jabber_authentication}) } }); $self->{iq_id} = 1; $self->{default_iq_timeout} = 60; $self->{disconnect_cb} = sub { my ($host, $port, $message) = @_; delete $self->{authenticated}; delete $self->{ssl_enabled}; $self->event (disconnect => $host, $port, $message); $self->{disconnect_cb} = sub {}; delete $self->{writer}; $self->{parser}->cleanup; delete $self->{parser}; }; if ($self->{jid}) { my ($user, $host, $res) = split_jid ($self->{jid}); $self->{username} = $user; $self->{domain} = $host; $self->{resource} = $res if defined $res; } $self->{host} = $self->{domain} unless defined $self->{host}; $self->{port} = 'xmpp-client=5222' unless defined $self->{port}; my $proxy_cb = sub { my ($self, $er) = @_; $self->event (error => $er); }; $self->reg_cb ( xml_parser_error => $proxy_cb, sasl_error => $proxy_cb, stream_error => $proxy_cb, bind_error => $proxy_cb, iq_auth_error => $proxy_cb, iq_result_cb_exception => sub { my ($self, $ex) = @_; $self->event (error => AnyEvent::XMPP::Error::Exception->new ( exception => $ex, context => 'iq result callback execution' ) ); }, tls_error => sub { my ($self) = @_; $self->event (error => AnyEvent::XMPP::Error->new (text => 'tls_error: tls negotiation failed') ); }, iq_xml => sub { shift @_; $self->handle_iq (@_) } ); if ($self->{whitespace_ping_interval} > 0) { $self->reg_cb ( stream_ready => sub { my ($self) = @_; $self->_start_whitespace_ping; $self->unreg_me; }, disconnect => sub { $self->_stop_whitespace_ping; $self->unreg_me; } ); } $self->set_exception_cb (sub { my ($ex) = @_; $self->event (error => AnyEvent::XMPP::Error::Exception->new ( exception => $ex, context => 'event callback' ) ); }); return $self; } =item B Try to connect (non blocking) to the domain and port passed in C. The connection is performed non blocking, so this method will just trigger the connection process. The event C will be emitted when the connection was successfully established. If the connection try was not successful a C event will be generated with an error message. NOTE: Please note that you can't reconnect a L object. You need to recreate it if you want to reconnect. NOTE: The "XML" stream initiation is sent when the connection was successfully connected. =cut sub connect { my ($self) = @_; $self->SUPER::connect ($self->{host}, $self->{port}, $self->{connect_timeout}); } sub connected { my ($self) = @_; if ($self->{old_style_ssl}) { $self->enable_ssl; } $self->init; $self->event (connect => $self->{peer_host}, $self->{peer_port}); } sub send_buffer_empty { my ($self) = @_; $self->event ('send_buffer_empty'); } sub handle_data { my ($self, $buf) = @_; $self->event (debug_recv => $$buf); $self->{parser}->feed (substr $$buf, 0, (length $$buf), ''); } sub debug_wrote_data { my ($self, $data) = @_; $self->event (debug_send => $data); } sub write_data { my ($self, $data) = @_; $self->event (send_stanza_data => $data); $self->SUPER::write_data ($data); } sub default_namespace { return 'client'; } sub handle_stanza { my ($self, $p, $node) = @_; if (not defined $node) { # got stream end $self->disconnect ("end of 'XML' stream encountered"); return; } my $stop = 0; $self->event (recv_stanza_xml => $node, \$stop); $stop and return; my $def_ns = $self->default_namespace; if ($node->eq (stream => 'features')) { $self->event (stream_features => $node); $self->{features} = $node; $self->handle_stream_features ($node); } elsif ($node->eq (tls => 'proceed')) { $self->enable_ssl; $self->{parser}->init; $self->{writer}->init; $self->{writer}->send_init_stream ( $self->{language}, $self->{domain}, $self->{stream_namespace} ); } elsif ($node->eq (tls => 'failure')) { $self->event ('tls_error'); $self->disconnect ('TLS failure on TLS negotiation.'); } elsif ($node->eq (sasl => 'challenge')) { $self->handle_sasl_challenge ($node); } elsif ($node->eq (sasl => 'success')) { $self->handle_sasl_success ($node); } elsif ($node->eq (sasl => 'failure')) { my $error = AnyEvent::XMPP::Error::SASL->new (node => $node); $self->event (sasl_error => $error); $self->disconnect ('SASL authentication failure: ' . $error->string); } elsif ($node->eq ($def_ns => 'iq')) { $self->event (iq_xml => $node); } elsif ($node->eq ($def_ns => 'message')) { $self->event (message_xml => $node); } elsif ($node->eq ($def_ns => 'presence')) { $self->event (presence_xml => $node); } elsif ($node->eq (stream => 'error')) { $self->handle_error ($node); } } # This method is private sub init { my ($self) = @_; $self->{writer}->send_init_stream ($self->{language}, $self->{domain}, $self->{stream_namespace}, $self->{stream_version_override}); } =item B Returns true if the connection is still connected and stanzas can be sent. =cut sub is_connected { my ($self) = @_; $self->{authenticated} } =item B This sets the default timeout for IQ requests. If the timeout runs out the request will be aborted and the callback called with a L object where the C method returns a special value (see also C method of L). The default timeout for IQ is 60 seconds. =cut sub set_default_iq_timeout { my ($self, $sec) = @_; $self->{default_iq_timeout} = $sec; } =item B This method sends an IQ XMPP B. If you want to B to a IQ request you received via the C, and C events you have to use the C or C methods documented below. Please take a look at the documentation for C in AnyEvent::XMPP::Writer about the meaning of C<$type>, C<$create_cb> and C<%attrs> (with the exception of the 'timeout' key of C<%attrs>, see below). C<$result_cb> will be called when a result was received or the timeout reached. The first argument to C<$result_cb> will be a AnyEvent::XMPP::Node instance containing the IQ result stanza contents. If the IQ resulted in a stanza error the second argument to C<$result_cb> will be C (if the error type was not 'continue') and the third argument will be a L object. The timeout can be set by C or passed separately in the C<%attrs> array as the value for the key C (timeout in seconds btw.). This method returns the newly generated id for this iq request. =cut sub send_iq { my ($self, $type, $create_cb, $result_cb, %attrs) = @_; my $id = $self->{iq_id}++; $self->{iqs}->{$id} = $result_cb; my $timeout = delete $attrs{timeout} || $self->{default_iq_timeout}; if ($timeout) { $self->{iq_timers}->{$id} = AnyEvent->timer (after => $timeout, cb => sub { delete $self->{iq_timers}->{$id}; my $cb = delete $self->{iqs}->{$id}; $cb->(undef, AnyEvent::XMPP::Error::IQ->new) }); } $self->{writer}->send_iq ($id, $type, $create_cb, %attrs); $id } =item B This method returns the next IQ id that will be used. =cut sub next_iq_id { $_[0]->{iq_id}; } =item B This method will generate a result reply to the iq request C in C<$req_iq_node>. Please take a look at the documentation for C in L about the meaning C<$create_cb> and C<%attrs>. Use C<$create_cb> to create the XML for the result. The type for this iq reply is 'result'. The C attribute of the reply stanza will be set to the C attribute of the C<$req_iq_node>. If C<$req_iq_node> had no C node it won't be set. If you want to overwrite the C field just pass it via C<%attrs>. =cut sub reply_iq_result { my ($self, $iqnode, $create_cb, %attrs) = @_; return $self->_reply_iq( $iqnode, 'result', $create_cb, %attrs ); } =item B This method will generate an error reply to the iq request C in C<$req_iq_node>. C<$error_type> is one of 'cancel', 'continue', 'modify', 'auth' and 'wait'. C<$error> is one of the defined error conditions described in C method of L. Please take a look at the documentation for C in AnyEvent::XMPP::Writer about the meaning of C<%attrs>. The type for this iq reply is 'error'. The C attribute of the reply stanza will be set to the C attribute of the C<$req_iq_node>. If C<$req_iq_node> had no C node it won't be set. If you want to overwrite the C field just pass it via C<%attrs>. =cut sub reply_iq_error { my ($self, $iqnode, $errtype, $error, %attrs) = @_; return $self->_reply_iq( $iqnode, 'error', sub { $self->{writer}->write_error_tag ($iqnode, $errtype, $error) }, %attrs ); } sub _reply_iq { my ($self, $iqnode, $type, $create_cb, %attrs) = @_; return $self->{writer}->send_iq ( $iqnode->attr ('id'), $type, $create_cb, (defined $iqnode->attr ('from') ? (to => $iqnode->attr ('from')) : ()), (defined $iqnode->attr ('to') ? (from => $iqnode->attr ('to')) : ()), %attrs ); } sub handle_iq { my ($self, $node) = @_; my $type = $node->attr ('type'); my $id = $node->attr ('id'); delete $self->{iq_timers}->{$id} if defined $id; if ($type eq 'result') { if (my $cb = delete $self->{iqs}->{$id}) { eval { $cb->($node); }; if ($@) { $self->event (iq_result_cb_exception => $@) } } } elsif ($type eq 'error') { if (my $cb = delete $self->{iqs}->{$id}) { my $error = AnyEvent::XMPP::Error::IQ->new (node => $node); eval { $cb->(($error->type eq 'continue' ? $node : undef), $error); }; if ($@) { $self->event (iq_result_cb_exception => $@) } } } else { my $handled = 0; $self->event ("iq_${type}_request_xml" => $node, \$handled); $handled or $self->reply_iq_error ($node, undef, 'service-unavailable'); } } sub send_sasl_auth { my ($self, @mechs) = @_; for (qw/username password domain/) { die "No '$_' argument given to new, but '$_' is required\n" unless defined $self->{$_}; } $self->{writer}->send_sasl_auth ( [map { $_->text } @mechs], $self->{username}, ($self->{use_host_as_sasl_hostname} ? $self->{host} : $self->{domain}), $self->{password} ); } sub handle_stream_features { my ($self, $node) = @_; my @bind = $node->find_all ([qw/bind bind/]); my @tls = $node->find_all ([qw/tls starttls/]); # and yet another weird thingie: in XEP-0077 it's said that # the register feature MAY be advertised by the server. That means: # it MAY not be advertised even if it is available... so we don't # care about it... # my @reg = $node->find_all ([qw/register register/]); if (not ($self->{disable_ssl}) && not ($self->{ssl_enabled}) && @tls) { $self->{writer}->send_starttls; } elsif (not $self->{authenticated}) { my $continue = 1; $self->event (stream_pre_authentication => \$continue); if ($continue) { $self->authenticate; } } elsif (@bind) { $self->do_rebind ($self->{resource}); } } =item B This method should be called after the C event was emitted to continue authentication of the stream. Usually this method only has to be called when you want to register before you authenticate. See also the documentation of the C event below. =cut sub authenticate { my ($self) = @_; my $node = $self->{features}; my @mechs = $node->find_all ([qw/sasl mechanisms/], [qw/sasl mechanism/]); # Yes, and also iq-auth isn't correctly advertised in the # stream features! We all love the depreacted XEP-0078, eh? my @iqa = $node->find_all ([qw/iqauth auth/]); if (not ($self->{disable_sasl}) && @mechs) { $self->send_sasl_auth (@mechs) } elsif (not $self->{disable_iq_auth}) { if ($self->{anal_iq_auth} && !@iqa) { if (@iqa) { $self->do_iq_auth; } else { die "No authentication method left after anal iq auth, neither SASL or IQ auth.\n"; } } else { $self->do_iq_auth; } } else { die "No authentication method left, neither SASL or IQ auth.\n"; } } sub handle_sasl_challenge { my ($self, $node) = @_; $self->{writer}->send_sasl_response ($node->text); } sub handle_sasl_success { my ($self, $node) = @_; $self->{authenticated} = 1; $self->{parser}->init; $self->{writer}->init; $self->{writer}->send_init_stream ( $self->{language}, $self->{domain}, $self->{stream_namespace} ); } sub handle_error { my ($self, $node) = @_; my $error = AnyEvent::XMPP::Error::Stream->new (node => $node); $self->event (stream_error => $error); $self->{writer}->send_end_of_stream; } # This is a hack for jabberd 1.4.2, VERY OLD Jabber stuff. sub start_old_style_authentication { my ($self) = @_; $self->{features} = AnyEvent::XMPP::Node->new ( 'http://etherx.jabber.org/streams', 'features', [], $self->{parser} ); my $continue = 1; $self->event (stream_pre_authentication => \$continue); if ($continue) { $self->do_iq_auth; } } sub do_iq_auth { my ($self) = @_; if ($self->{anal_iq_auth}) { $self->send_iq (get => { defns => 'auth', node => { ns => 'auth', name => 'query', # heh, something i've seen on some ejabberd site: # childs => [ { name => 'username', childs => [ $self->{username} ] } ] } }, sub { my ($n, $e) = @_; if ($e) { $self->event (iq_auth_error => AnyEvent::XMPP::Error::IQAuth->new (context => 'iq_error', iq_error => $e) ); } else { my $fields = {}; my (@query) = $n->find_all ([qw/auth query/]); if (@query) { for (qw/username password digest resource/) { if ($query[0]->find_all ([qw/auth/, $_])) { $fields->{$_} = 1; } } $self->do_iq_auth_send ($fields); } else { $self->event (iq_auth_error => AnyEvent::XMPP::Error::IQAuth->new (context => 'no_fields') ); } } }); } else { $self->do_iq_auth_send ({ username => 1, password => 1, resource => 1 }); } } sub do_iq_auth_send { my ($self, $fields) = @_; for (qw/username password resource/) { die "No '$_' argument given to new, but '$_' is required\n" unless defined $self->{$_}; } my $do_resource = $fields->{resource}; my $password = $self->{password}; if ($fields->{digest}) { my $out_password = encode ("UTF-8", $password); my $out = lc sha1_hex ($self->stream_id () . $out_password); $fields = { username => $self->{username}, digest => $out, } } else { $fields = { username => $self->{username}, password => $password } } if ($do_resource && defined $self->{resource}) { $fields->{resource} = $self->{resource} } $self->send_iq (set => { defns => 'auth', node => { ns => 'auth', name => 'query', childs => [ map { { name => $_, childs => [ $fields->{$_} ] } } reverse sort keys %$fields ]} }, sub { my ($n, $e) = @_; if ($e) { $self->event (iq_auth_error => AnyEvent::XMPP::Error::IQAuth->new (context => 'iq_error', iq_error => $e) ); } else { $self->{authenticated} = 1; $self->{jid} = join_jid ($self->{username}, $self->{domain}, $self->{resource}); $self->event (stream_ready => $self->{jid}); } }); } =item B This method sends a presence stanza, for the meanings of C<$type>, C<$create_cb> and C<%attrs> please take a look at the documentation for C method of L. This methods does attach an id attribute to the presence stanza and will return the id that was used (so you can react on possible replies). =cut sub send_presence { my ($self, $type, $create_cb, %attrs) = @_; my $id = $self->{iq_id}++; $self->{writer}->send_presence ($id, $type, $create_cb, %attrs); $id } =item B This method sends a message stanza, for the meanings of C<$to>, C<$type>, C<$create_cb> and C<%attrs> please take a look at the documentation for C method of L. This methods does attach an id attribute to the message stanza and will return the id that was used (so you can react on possible replies). =cut sub send_message { my ($self, $to, $type, $create_cb, %attrs) = @_; my $id = delete $attrs{id} || $self->{iq_id}++; $self->{writer}->send_message ($id, $to, $type, $create_cb, %attrs); $id } =item B In case you got a C event and want to retry binding you can call this function to set a new C<$resource> and retry binding. If it fails again you can call this again. Becareful not to end up in a loop! If binding was successful the C event will be generated. =cut sub do_rebind { my ($self, $resource) = @_; $self->{resource} = $resource; $self->send_iq ( set => sub { my ($w) = @_; if ($self->{resource}) { simxml ($w, defns => 'bind', node => { name => 'bind', childs => [ { name => 'resource', childs => [ $self->{resource} ] } ] } ) } else { simxml ($w, defns => 'bind', node => { name => 'bind' }) } }, sub { my ($ret_iq, $error) = @_; if ($error) { # TODO: make bind error into a seperate error class? if ($error->xml_node ()) { my ($res) = $error->xml_node ()->find_all ([qw/bind bind/], [qw/bind resource/]); $self->event (bind_error => $error, ($res ? $res : $self->{resource})); } else { $self->event (bind_error => $error); } } else { my @jid = $ret_iq->find_all ([qw/bind bind/], [qw/bind jid/]); my $jid = $jid[0]->text; unless ($jid) { die "Got empty JID tag from server!\n" } $self->{jid} = $jid; $self->event (stream_ready => $jid); } } ); } sub _start_whitespace_ping { my ($self) = @_; return unless $self->{whitespace_ping_interval} > 0; $self->{_ws_ping} = AnyEvent->timer (after => $self->{whitespace_ping_interval}, cb => sub { $self->{writer}->send_whitespace_ping; $self->_start_whitespace_ping; }); } sub _stop_whitespace_ping { delete $_[0]->{_ws_ping}; } =item B After the stream has been bound to a resource the JID can be retrieved via this method. =cut sub jid { $_[0]->{jid} } =item B Returns the last received tag in form of an L object. =cut sub features { $_[0]->{features} } =item B This is the ID of this stream that was given us by the server. =cut sub stream_id { $_[0]->{stream_id} } =back =head1 EVENTS The L class is derived from the L class, and thus inherits the event callback registering system from it. Consult the documentation of L about more details. NODE: Every callback gets as it's first argument the L object. The further callback arguments are described in the following listing of events. These events can be registered on with C: =over 4 =item stream_features => $node This event is sent when a stream feature () tag is received. C<$node> is the L object that represents the tag. =item stream_pre_authentication This event is emitted after TLS/SSL was initiated (if enabled) and before any authentication happened. The return value of the first event callback that is called decides what happens next. If it is true value the authentication continues. If it is undef or a false value authentication is stopped and you need to call C later. value This event is usually used when you want to do in-band registration, see also L. =item stream_ready => $jid This event is sent if the XML stream has been established (and resources have been bound) and is ready for transmitting regular stanzas. C<$jid> is the bound jabber id. =item error => $error This event is generated whenever some error occured. C<$error> is an instance of L. Trivial error reporting may look like this: $con->reg_cb (error => sub { warn "xmpp error: " . $_[1]->string . "\n" }); Basically this event is a collect event for all other error events. =item stream_error => $error This event is sent if a XML stream error occured. C<$error> is a L object. =item xml_parser_error => $error This event is generated whenever the parser trips over XML that it can't read. C<$error> is a L object. =item tls_error This event is emitted when a TLS error occured on TLS negotiation. After this the connection will be disconnected. =item sasl_error => $error This event is emitted on SASL authentication error. =item iq_auth_error => $error This event is emitted when IQ authentication (XEP-0078) failed. =item bind_error => $error, $resource This event is generated when the stream was unable to bind to any or the in C specified resource. C<$error> is a L object. C<$resource> is the errornous resource string or undef if none was received. The C of the C<$error> might be one of: 'bad-request', 'not-allowed' or 'conflict'. Node: this is untested, I couldn't get the server to send a bind error to test this. =item connect => $host, $port This event is generated when a successful TCP connect was performed to the domain passed to C. Note: C<$host> and C<$port> might be different from the domain you passed to C if C performed a SRV RR lookup. If this connection is lost a C will be generated with the same C<$host> and C<$port>. =item disconnect => $host, $port, $message This event is generated when the TCP connection was lost or another error occurred while writing or reading from it. C<$message> is a human readable error message for the failure. C<$host> and C<$port> were the host and port we were connected to. Note: C<$host> and C<$port> might be different from the domain you passed to C if C performed a SRV RR lookup. =item recv_stanza_xml => $node, $rstop This event is generated before any processing of a "XML" stanza happens. C<$node> is the node of the stanza that is being processed, it's of type L. This method might not be as handy for debugging purposes as C. If you want to handle the stanza yourself and don't want this module to take care of it set a true value to the scalar referenced by C<$rstop>. =item send_stanza_data => $data This event is generated shortly before data is sent to the socket. C<$data> contains a complete "XML" stanza or the end of stream closing tag. This method is useful for debugging purposes and I recommend using XML::Twig or something like that to display it nicely. See also the event C. =item debug_send => $data This method is invoked whenever data is written out. This event is mostly the same as C. =item debug_recv => $data This method is invoked whenever a chunk of data was received. It works to filter C<$data> through L for debugging display purposes sometimes, but as C<$data> is some arbitrary chunk of bytes you might get a XML parse error (did I already mention that XMPP's application of "XML" sucks?). So you might want to use C to detect complete stanzas. Unfortunately C doesn't have the bytes anymore and just a data structure (L). =item send_buffer_empty This event is VERY useful if you want to wait (or at least be notified) when the output buffer is empty. If you got a bunch of messages to sent or even one and you want to do something when the output buffer is empty, you can wait for this event. It is emitted every time the output buffer is completely written out to the kernel. Here is an example: $con->reg_cb (send_buffer_empty => sub { $con->disconnect ("wrote message, going to disconnect now..."); }); $con->send_message ("Test message!" => 'elmex@jabber.org', undef, 'chat'); =item presence_xml => $node This event is sent when a presence stanza is received. C<$node> is the L object that represents the tag. If you want to overtake the handling of the stanza, see C below. =item message_xml => $node This event is sent when a message stanza is received. C<$node> is the L object that represents the tag. If you want to overtake the handling of the stanza, see C below. =item iq_xml => $node This event is emitted when a iq stanza arrives. C<$node> is the L object that represents the tag. If you want to overtake the handling of a stanza, you should register a callback for the C event and call the C method. See also L. This is an example: $con->reg_cb (before_iq_xml => sub { my ($con, $node) = @_; if (...) { # and stop_event will stop internal handling of the stanza: $con->stop_event; } }); Please note that if you overtake handling of a stanza none of the internal handling of that stanza will be done. That means you won't get events like C anymore. =item iq_set_request_xml => $node, $rhandled =item iq_get_request_xml => $node, $rhandled These events are sent when an iq request stanza of type 'get' or 'set' is received. C<$type> will either be 'get' or 'set' and C<$node> will be the L object of the iq tag. To signal the stanza was handled set the scalar referenced by C<$rhandled> to a true value. If the stanza was not handled an error iq will be generated. =item iq_result_cb_exception => $exception If the C<$result_cb> of a C operation somehow threw a exception or failed this event will be generated. =item send_iq_hook => $id, $type, $attrs, \@create_cb This event lets you add any desired number of additional create callbacks to a IQ stanza that is about to be sent. C<$id>, C<$type> are described in the documentation of C of L. C<$attrs> is the hashref to the C<%attrs> hash that can be passed to C and also has the exact same semantics as described in the documentation of C. You can push values into C (as documented for C), for example a callback that fills the IQ. Example: # this appends a element to all outgoing IQs # and also a element to all outgoing IQs $con->reg_cb (send_iq_hook => sub { my ($con, $id, $type, $attrs, $create_cb) = @_; push @$create_cb, sub { my $w = shift; # $w is a XML::Writer instance $w->emptyTag ('test'); }; push @$create_cb, { node => { name => "test2" } # see also simxml() defined in AnyEvent::XMPP::Util }; }); =item send_message_hook => $id, $to, $type, $attrs, \@create_cb This event lets you add any desired number of additional create callbacks to a message stanza that is about to be sent. C<$id>, C<$to>, C<$type> and the hashref C<$attrs> are described in the documentation for C of L (C<$attrs> is C<%attrs> there). To actually append something you need to push into C as described in the C event above. =item send_presence_hook => $id, $type, $attrs, \@create_cb This event lets you add any desired number of additional create callbacks to a presence stanza that is about to be sent. C<$id>, C<$type> and the hashref C<$attrs> are described in the documentation for C of L (C<$attrs> is C<%attrs> there). To actually append something you need to push into C as described in the C event above. =back =head1 AUTHOR Robin Redeker, C<< >>, JID: C<< >> =head1 CONTRIBUTORS melo - minor fixes =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.55/lib/AnyEvent/XMPP/Extendable.pm0000644000014500017510000000255512066334771020757 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.55/lib/AnyEvent/XMPP/SimpleConnection.pm0000644000014500017510000000533512273241773022153 0ustar michaelstaffpackage AnyEvent::XMPP::SimpleConnection; use strict; no warnings; use AnyEvent; use IO::Handle; use Encode; use AnyEvent::Socket; use AnyEvent::Handle; =head1 NAME AnyEvent::XMPP::SimpleConnection - Low level TCP/TLS connection =head1 SYNOPSIS package foo; use AnyEvent::XMPP::SimpleConnection; our @ISA = qw/AnyEvent::XMPP::SimpleConnection/; =head1 DESCRIPTION This module only implements the basic low level socket and SSL handling stuff. It is used by L and you shouldn't mess with it :-) (NOTE: This is the part of AnyEvent::XMPP which I feel least confident about :-) =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = { disconnect_cb => sub {}, @_ }; bless $self, $class; return $self; } sub connect { my ($self, $host, $service, $timeout) = @_; $self->{handle} and return 1; $self->{handle} = tcp_connect $host, $service, sub { my ($fh, $peerhost, $peerport) = @_; unless ($fh) { $self->disconnect ("Couldn't create socket to $host:$service: $!"); return; } $self->{peer_host} = $peerhost; $self->{peer_port} = $peerport; binmode $fh, ":raw"; $self->{handle} = AnyEvent::Handle->new ( fh => $fh, on_eof => sub { $self->disconnect ("EOF on connection to $self->{peer_host}:$self->{peer_port}: $!"); }, autocork => 1, on_error => sub { $self->disconnect ("Error on connection to $self->{peer_host}:$self->{peer_port}: $!"); }, on_read => sub { my ($hdl) = @_; my $data = $hdl->rbuf; $hdl->rbuf = ''; $data = decode_utf8 $data; $self->handle_data (\$data); }, ); $self->connected }, sub { $timeout }; return 1; } sub connected { # subclass responsibility } sub send_buffer_empty { # subclass responsibility } sub block_until_send_buffer_empty { # subclass responsibility } sub debug_wrote_data { # subclass responsibility } sub end_sockets { my ($self) = @_; delete $self->{handle}; } sub write_data { my ($self, $data) = @_; $self->{handle}->push_write (encode_utf8 ($data)); $self->debug_wrote_data (encode_utf8 ($data)); $self->{handle}->on_drain (sub { $self->send_buffer_empty; }); } sub enable_ssl { my ($self) = @_; $self->{handle}->starttls ('connect'); $self->{ssl_enabled} = 1; } sub disconnect { my ($self, $msg) = @_; $self->end_sockets; $self->{disconnect_cb}->($self->{peer_host}, $self->{peer_port}, $msg); $self->remove_all_callbacks; } 1; AnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Namespaces.pm0000644000014500017510000001046112066334771020756 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.55/lib/AnyEvent/XMPP/Writer.pm0000644000014500017510000005404712066334771020163 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.55/lib/AnyEvent/XMPP/Parser.pm0000644000014500017510000001306712066334771020140 0ustar michaelstaffpackage AnyEvent::XMPP::Parser; no warnings; use strict; use AnyEvent::XMPP::Node; # OMFG!!!111 THANK YOU FOR THIS MODULE TO HANDLE THE XMPP INSANITY: use XML::Parser::Expat; =head1 NAME AnyEvent::XMPP::Parser - Parser for XML streams (helper for AnyEvent::XMPP) =head1 SYNOPSIS use AnyEvent::XMPP::Parser; ... =head1 DESCRIPTION This is a XMPP XML parser helper class, which helps me to cope with the XMPP XML. See also L for a discussion of the issues with XML in XMPP. =head1 METHODS =over 4 =item B This creates a new AnyEvent::XMPP::Parser and calls C. =cut sub new { my $this = shift; my $class = ref($this) || $this; my $self = { stanza_cb => sub { die "No stanza callback provided!" }, error_cb => sub { warn "No error callback provided: $_[0]: $_[1]!" }, stream_cb => sub { }, @_ }; bless $self, $class; $self->init; $self } =item B Sets the 'XML stanza' callback. C<$cb> must be a code reference. The first argument to the callback will be this AnyEvent::XMPP::Parser instance and the second will be the stanzas root AnyEvent::XMPP::Node as first argument. If the second argument is undefined the end of the stream has been found. =cut sub set_stanza_cb { my ($self, $cb) = @_; $self->{stanza_cb} = $cb; } =item B This sets the error callback that will be called when the parser encounters an syntax error. The first argument is the exception and the second is the data which caused the error. =cut sub set_error_cb { my ($self, $cb) = @_; $self->{error_cb} = $cb; } =item B This method sets the stream tag callback. It is called when the tag from the server has been encountered. The first argument to the callback is the L of the opening stream tag. =cut sub set_stream_cb { my ($self, $cb) = @_; $self->{stream_cb} = $cb; } =item B This methods (re)initializes the parser. =cut sub init { my ($self) = @_; $self->{parser} = XML::Parser::ExpatNB->new ( Namespaces => 1, ProtocolEncoding => 'UTF-8' ); $self->{parser}->setHandlers ( Start => sub { $self->cb_start_tag (@_) }, End => sub { $self->cb_end_tag (@_) }, Char => sub { $self->cb_char_data (@_) }, Default => sub { $self->cb_default (@_) }, ); $self->{nso} = {}; $self->{nodestack} = []; } =item B This methods removes all handlers. Use it to avoid circular references. =cut sub cleanup { my ($self) = @_; for (qw(stanza_cb error_cb stream_cb parser)) { delete $self->{$_}; } return; } =item B This method checks whether the C<$cmptag> matches the C<$tagname> in the C<$namespace>. C<$cmptag> needs to come from the XML::Parser::Expat as it has some magic attached that stores the namespace. =cut sub nseq { my ($self, $ns, $name, $tag) = @_; unless (exists $self->{nso}->{$ns}->{$name}) { $self->{nso}->{$ns}->{$name} = $self->{parser}->generate_ns_name ($name, $ns); } return $self->{parser}->eq_name ($self->{nso}->{$ns}->{$name}, $tag); } =item B This method feeds a chunk of unparsed data to the parser. =cut sub feed { my ($self, $data) = @_; eval { $self->{parser}->parse_more ($data); }; if ($@) { if ($self->{error_cb}) { $self->{error_cb}->($@, $data, 'xml'); } else { warn "parser error: $@ on [$data]\n"; } } } sub cb_start_tag { my ($self, $p, $el, %attrs) = @_; my $node = AnyEvent::XMPP::Node->new ($p->namespace ($el), $el, \%attrs, $self); $node->append_raw ($p->recognized_string); if (not @{$self->{nodestack}}) { $self->{stream_cb}->($node); } push @{$self->{nodestack}}, $node; } sub cb_char_data { my ($self, $p, $str) = @_; unless (@{$self->{nodestack}}) { warn "characters outside of tag: [$str]!\n"; return; } return if @{$self->{nodestack}} < 2; # don't append anything to the stream element my $node = $self->{nodestack}->[-1]; $node->add_text ($str); $node->append_raw ($p->recognized_string); } sub cb_end_tag { my ($self, $p, $el) = @_; unless (@{$self->{nodestack}}) { warn "end tag read without any starting tag!\n"; return; } if (!$p->eq_name ($self->{nodestack}->[-1]->name, $el)) { warn "end tag doesn't match start tags ($self->{tags}->[-1]->[0])!\n"; return; } my $node = pop @{$self->{nodestack}}; $node->append_raw ($p->recognized_string); # > 1 because we don't want the stream tag to save all our children... if (@{$self->{nodestack}} > 1) { $self->{nodestack}->[-1]->add_node ($node); } eval { if (@{$self->{nodestack}} == 1) { $self->{stanza_cb}->($self, $node); } elsif (@{$self->{nodestack}} == 0) { $self->{stanza_cb}->($self, undef); } }; if ($@) { $self->{error_cb}->($@, undef, 'exception'); } } sub cb_default { my ($self, $p, $str) = @_; $self->{nodestack}->[-1]->append_raw ($str) if @{$self->{nodestack}} > 1; # don't append to the stream element } =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 sub DESTROY { my ($self) = @_; $self->{parser}->release if defined($self->{parser}); } 1; # End of AnyEvent::XMPP AnyEvent-XMPP-0.55/lib/AnyEvent/XMPP/Ext.pm0000644000014500017510000001234712066334771017444 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.55/lib/AnyEvent/XMPP/Error.pm0000644000014500017510000000300212066334771017761 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.55/lib/AnyEvent/XMPP/Util.pm0000644000014500017510000003336112066334771017620 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