Net-XMPP-1.02000777000000000000 010603223625 13276 5ustar00unknownunknown000000000000Build.PL000444000000000000 73210601762147 14633 0ustar00unknownunknown000000000000Net-XMPP-1.02use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'Net::XMPP', license => 'lgpl', dist_author => 'xmpplar', dist_abstract => 'XMPP Support Library', dist_version_from => 'lib/Net/XMPP.pm', requires => { 'XML::Stream' => 1.22, 'Digest::SHA1' => 1.02, }, create_makefile_pl => 'passthrough', ); $builder->create_build_script(); CHANGES000444000000000000 250310602731625 14346 0ustar00unknownunknown000000000000Net-XMPP-1.021.0.2 $Id: CHANGES 28 2007-03-29 12:39:48Z hacker $ === - Fix bug in Stanza::_xpath_defined causing defined to pass when it shouldn't which broke GetTimeStamp - Added test get_time_stamps.test, disabled due to XML::Stream bug on Windows. - Copied *X subs from Net::Jabber::Message to Net::XMPP::Message - added debugging in some Protocol subs that didn't have it, but not all - disabled CODE checking in Protocol-Callback subs to be POE compatable Should be put into registration, not on callback, but didn't do that yet - changed mytestlib.pl to output more concise test names 1.0.1 === - Fixed bug in Execute() where it would not reconnect correctly. Thanks to bianchi. - Fixed bad xpath in iq:register. Thanks to Julian Yon. - Fixed minor bug in tests thanks to Alexey Tourbin. to dsanot. - Fixed bug in default callbacks. The inheritance model I was using was completely screwed up. 1.0 === - Should be stable enough for a 1.0 release. - More merges from Net::Jabber to make this stable. 0.1 === - Initial port from Net::Jabber. This will ultimatly end up being an inheritable base for doing XMPP connections. Net::Jabber will be re-written to use Net::XMPP for base connections and simply provide the Jabber extensions that the Jabber Software Foundation is managing. LICENSE.LGPL000444000000000000 6143710573261144 15151 0ustar00unknownunknown000000000000Net-XMPP-1.02 GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! Makefile.PL000444000000000000 215410603223625 15324 0ustar00unknownunknown000000000000Net-XMPP-1.02# Note: this file was auto-generated by Module::Build::Compat version 0.03 unless (eval "use Module::Build::Compat 0.02; 1" ) { print "This module requires Module::Build to install itself.\n"; require ExtUtils::MakeMaker; my $yn = ExtUtils::MakeMaker::prompt (' Install Module::Build now from CPAN?', 'y'); unless ($yn =~ /^y/i) { die " *** Cannot install without Module::Build. Exiting ...\n"; } require Cwd; require File::Spec; require CPAN; # Save this 'cause CPAN will chdir all over the place. my $cwd = Cwd::cwd(); CPAN::Shell->install('Module::Build::Compat'); CPAN::Shell->expand("Module", "Module::Build::Compat")->uptodate or die "Couldn't install Module::Build, giving up.\n"; chdir $cwd or die "Cannot chdir() back to $cwd: $!"; } eval "use Module::Build::Compat 0.02; 1" or die $@; Module::Build::Compat->run_build_pl(args => \@ARGV); require Module::Build; Module::Build::Compat->write_makefile(build_class => 'Module::Build'); MANIFEST000444000000000000 141710603223613 14501 0ustar00unknownunknown000000000000Net-XMPP-1.02Build.PL CHANGES examples/client.pl examples/client_xpath.pl lib/Net/XMPP.pm lib/Net/XMPP/Client.pm lib/Net/XMPP/Connection.pm lib/Net/XMPP/Debug.pm lib/Net/XMPP/IQ.pm lib/Net/XMPP/JID.pm lib/Net/XMPP/Message.pm lib/Net/XMPP/Namespaces.pm lib/Net/XMPP/Presence.pm lib/Net/XMPP/PrivacyLists.pm lib/Net/XMPP/Protocol.pm lib/Net/XMPP/Roster.pm lib/Net/XMPP/Stanza.pm LICENSE.LGPL Makefile.PL MANIFEST This list of files META.yml README stderr t/1_load.t t/2_client_jabberd1.4.t t/3_client_jabberd2.t t/get_time_stamp.test t/iq.t t/jid.t t/lib/Test/Builder.pm t/lib/Test/More.pm t/lib/Test/Simple.pm t/message.t t/mytestlib.pl t/node1.xml t/node2.xml t/packet_iqauth.t t/packet_iqroster.t t/presence.t t/query_xxxxx.test t/rawxml.t t/roster.t META.yml000444000000000000 221210603223625 14616 0ustar00unknownunknown000000000000Net-XMPP-1.02--- #YAML:1.0 name: Net-XMPP version: 1.02 author: - xmpplar abstract: XMPP Support Library license: lgpl resources: license: |- http://opensource.org/licenses/artistic-license.php requires: Digest::SHA1: 1.02 XML::Stream: 1.22 provides: Net::XMPP: file: lib/Net/XMPP.pm version: 1.02 Net::XMPP::Client: file: lib/Net/XMPP/Client.pm Net::XMPP::Connection: file: lib/Net/XMPP/Connection.pm Net::XMPP::Debug: file: lib/Net/XMPP/Debug.pm Net::XMPP::IQ: file: lib/Net/XMPP/IQ.pm Net::XMPP::JID: file: lib/Net/XMPP/JID.pm Net::XMPP::Message: file: lib/Net/XMPP/Message.pm Net::XMPP::Namespaces: file: lib/Net/XMPP/Namespaces.pm Net::XMPP::Presence: file: lib/Net/XMPP/Presence.pm Net::XMPP::PrivacyLists: file: lib/Net/XMPP/PrivacyLists.pm Net::XMPP::Protocol: file: lib/Net/XMPP/Protocol.pm Net::XMPP::Roster: file: lib/Net/XMPP/Roster.pm Net::XMPP::Stanza: file: lib/Net/XMPP/Stanza.pm generated_by: Module::Build version 0.2805 meta-spec: url: |- http://module-build.sourceforge.net/META-spec-v1.2.html version: 1.2 README000444000000000000 225110573261144 14234 0ustar00unknownunknown000000000000Net-XMPP-1.02Net::XMPP v1.0 The Extensible Messaging and Presence Protocol (XMPP) is an IETF standard that provides a complete cross protocol messaging solution. The problem with current IM solutions is that they are all proprietary and cannot talk to each other. XMPP seeks to get rid of those barriers. For more information about the Jabber project visit http://www.xmpp.org. Net::XMPP is a collection of Perl modules that provide a Perl Developer access to the XMPP protocol. Using OOP modules we provide a clean interface to writing anything from a full client to a simple protocol tester. Ryan Eatmon reatmon@jabber.org REQUIREMENTS - XML::Stream - Handles the connection between the Client and the Server. - Digest::SHA1 - Encrypted authorization so that your password is not sent over unsecure XML. INSTALLATION perl Makefile.PL make make install STATUS Beta. There is some more testing and features to add before I'm ready to call this 1.0. It should be usable, but I would not put any production code using this yet. If you run into problems, downgrade to Net::Jabber 1.29. Please send any bug reports to reatmon@jabber.org. 2004/08/22 stderr000444000000000000 156510602004264 14600 0ustar00unknownunknown000000000000Net-XMPP-1.02XML::Stream: new: hostname = (glaucon.vudu.net) XML::Stream: SetCallBacks: tag(node) func(CODE(0x354bcc8)) XMPP::Conn: xmppCallbackInit: start XMPP::Conn: SetCallBacks: tag(message) func(CODE(0x354beb4)) XMPP::Conn: SetCallBacks: tag(presence) func(CODE(0x354be54)) XMPP::Conn: SetCallBacks: tag(iq) func(CODE(0x354bdf4)) XMPP::Conn: SetPresenceCallBacks: type(subscribe) func(CODE(0x354be48)) XMPP::Conn: SetPresenceCallBacks: type(subscribed) func(CODE(0x354c028)) XMPP::Conn: SetPresenceCallBacks: type(unsubscribe) func(CODE(0x354bfc8)) XMPP::Conn: SetPresenceCallBacks: type(unsubscribed) func(CODE(0x354c088)) XMPP::Conn: SetDirectXPathCallBacks: xpath(/[@xmlns="urn:ietf:params:xml:ns:xmpp-tls"]) func(CODE(0x354c148)) XMPP::Conn: SetDirectXPathCallBacks: xpath(/[@xmlns="urn:ietf:params:xml:ns:xmpp-sasl"]) func(CODE(0x354c25c)) XMPP::Conn: xmppCallbackInit: stop examples000777000000000000 010603223625 15035 5ustar00unknownunknown000000000000Net-XMPP-1.02client.pl000444000000000000 536310573261144 17014 0ustar00unknownunknown000000000000Net-XMPP-1.02/examples use Net::XMPP; use strict; if ($#ARGV < 4) { print "\nperl client.pl \n\n"; exit(0); } my $server = $ARGV[0]; my $port = $ARGV[1]; my $username = $ARGV[2]; my $password = $ARGV[3]; my $resource = $ARGV[4]; $SIG{HUP} = \&Stop; $SIG{KILL} = \&Stop; $SIG{TERM} = \&Stop; $SIG{INT} = \&Stop; my $Connection = new Net::XMPP::Client(); $Connection->SetCallBacks(message=>\&InMessage, presence=>\&InPresence, iq=>\&InIQ); my $status = $Connection->Connect(hostname=>$server, port=>$port); if (!(defined($status))) { print "ERROR: Jabber server is down or connection was not allowed.\n"; print " ($!)\n"; exit(0); } my @result = $Connection->AuthSend(username=>$username, password=>$password, resource=>$resource); if ($result[0] ne "ok") { print "ERROR: Authorization failed: $result[0] - $result[1]\n"; exit(0); } print "Logged in to $server:$port...\n"; $Connection->RosterGet(); print "Getting Roster to tell server to send presence info...\n"; $Connection->PresenceSend(); print "Sending presence to tell world that we are logged in...\n"; while(defined($Connection->Process())) { } print "ERROR: The connection was killed...\n"; exit(0); sub Stop { print "Exiting...\n"; $Connection->Disconnect(); exit(0); } sub InMessage { my $sid = shift; my $message = shift; my $type = $message->GetType(); my $fromJID = $message->GetFrom("jid"); my $from = $fromJID->GetUserID(); my $resource = $fromJID->GetResource(); my $subject = $message->GetSubject(); my $body = $message->GetBody(); print "===\n"; print "Message ($type)\n"; print " From: $from ($resource)\n"; print " Subject: $subject\n"; print " Body: $body\n"; print "===\n"; print $message->GetXML(),"\n"; print "===\n"; } sub InIQ { my $sid = shift; my $iq = shift; my $from = $iq->GetFrom(); my $type = $iq->GetType(); my $query = $iq->GetQuery(); my $xmlns = $query->GetXMLNS(); print "===\n"; print "IQ\n"; print " From $from\n"; print " Type: $type\n"; print " XMLNS: $xmlns"; print "===\n"; print $iq->GetXML(),"\n"; print "===\n"; } sub InPresence { my $sid = shift; my $presence = shift; my $from = $presence->GetFrom(); my $type = $presence->GetType(); my $status = $presence->GetStatus(); print "===\n"; print "Presence\n"; print " From $from\n"; print " Type: $type\n"; print " Status: $status\n"; print "===\n"; print $presence->GetXML(),"\n"; print "===\n"; } client_xpath.pl000444000000000000 542610573261144 20220 0ustar00unknownunknown000000000000Net-XMPP-1.02/examples use Net::XMPP qw(Client); use strict; if ($#ARGV < 4) { print "\nperl client.pl \n\n"; exit(0); } my $server = $ARGV[0]; my $port = $ARGV[1]; my $username = $ARGV[2]; my $password = $ARGV[3]; my $resource = $ARGV[4]; $SIG{HUP} = \&Stop; $SIG{KILL} = \&Stop; $SIG{TERM} = \&Stop; $SIG{INT} = \&Stop; my $Connection = new Net::XMPP::Client(); $Connection->SetXPathCallBacks('/message'=>\&InMessage, '/presence'=>\&InPresence, '/iq'=>\&InIQ); my $status = $Connection->Connect(hostname=>$server, port=>$port); if (!(defined($status))) { print "ERROR: Jabber server is down or connection was not allowed.\n"; print " ($!)\n"; exit(0); } my @result = $Connection->AuthSend(username=>$username, password=>$password, resource=>$resource); if ($result[0] ne "ok") { print "ERROR: Authorization failed: $result[0] - $result[1]\n"; exit(0); } print "Logged in to $server:$port...\n"; $Connection->RosterGet(); print "Getting Roster to tell server to send presence info...\n"; $Connection->PresenceSend(); print "Sending presence to tell world that we are logged in...\n"; while(defined($Connection->Process())) { } print "ERROR: The connection was killed...\n"; exit(0); sub Stop { print "Exiting...\n"; $Connection->Disconnect(); exit(0); } sub InMessage { my $sid = shift; my $message = shift; my $type = $message->GetType(); my $fromJID = $message->GetFrom("jid"); my $from = $fromJID->GetUserID(); my $resource = $fromJID->GetResource(); my $subject = $message->GetSubject(); my $body = $message->GetBody(); print "===\n"; print "Message ($type)\n"; print " From: $from ($resource)\n"; print " Subject: $subject\n"; print " Body: $body\n"; print "===\n"; print $message->GetXML(),"\n"; print "===\n"; } sub InIQ { my $sid = shift; my $iq = shift; my $from = $iq->GetFrom(); my $type = $iq->GetType(); my $query = $iq->GetQuery(); my $xmlns = $query->GetXMLNS(); print "===\n"; print "IQ\n"; print " From $from\n"; print " Type: $type\n"; print " XMLNS: $xmlns"; print "===\n"; print $iq->GetXML(),"\n"; print "===\n"; } sub InPresence { my $sid = shift; my $presence = shift; my $from = $presence->GetFrom(); my $type = $presence->GetType(); my $status = $presence->GetStatus(); print "===\n"; print "Presence\n"; print " From $from\n"; print " Type: $type\n"; print " Status: $status\n"; print "===\n"; print $presence->GetXML(),"\n"; print "===\n"; } lib000777000000000000 010603223625 13765 5ustar00unknownunknown000000000000Net-XMPP-1.02Net000777000000000000 010603223625 14513 5ustar00unknownunknown000000000000Net-XMPP-1.02/libXMPP.pm000444000000000000 3043110603222071 16001 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net############################################################################### # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################### package Net::XMPP; =head1 NAME Net::XMPP - XMPP Perl Library =head1 SYNOPSIS Net::XMPP provides a Perl user with access to the Extensible Messaging and Presence Protocol (XMPP). For more information about XMPP visit: http://www.xmpp.org =head1 DESCRIPTION Net::XMPP is a convenient tool to use for any perl script that would like to utilize the XMPP Instant Messaging protocol. While not a client in and of itself, it provides all of the necessary back-end functions to make a CGI client or command-line perl client feasible and easy to use. Net::XMPP is a wrapper around the rest of the official Net::XMPP::xxxxxx packages. There is are example scripts in the example directory that provide you with examples of very simple XMPP programs. NOTE: The parser that XML::Stream::Parser provides, as are most Perl parsers, is synchronous. If you are in the middle of parsing a packet and call a user defined callback, the Parser is blocked until your callback finishes. This means you cannot be operating on a packet, send out another packet and wait for a response to that packet. It will never get to you. Threading might solve this, but as of this writing threading in Perl is not quite up to par yet. This issue will be revisted in the future. =head1 EXAMPLES use Net::XMPP; my $client = new Net::XMPP::Client(); =head1 METHODS The Net::XMPP module does not define any methods that you will call directly in your code. Instead you will instantiate objects that call functions from this module to do work. The three main objects that you will work with are the Message, Presence, and IQ modules. Each one corresponds to the Jabber equivilant and allows you get and set all parts of those packets. There are a few functions that are the same across all of the objects: =head2 Retrieval functions GetXML() - returns the XML string that represents the data contained in the object. $xml = $obj->GetXML(); GetChild() - returns an array of Net::XMPP::Stanza objects GetChild(namespace) that represent all of the stanzas in the object that are namespaced. If you specify a namespace then only stanza objects with that XMLNS are returned. @xObj = $obj->GetChild(); @xObj = $obj->GetChild("my:namespace"); GetTag() - return the root tag name of the packet. GetTree() - return the XML::Stream::Node object that contains the data. See XML::Stream::Node for methods you can call on this object. =head2 Creation functions NewChild(namespace) - creates a new Net::XMPP::Stanza object with NewChild(namespace,tag) the specified namespace and root tag of whatever the namespace says its root tag should be. Optionally you may specify another root tag if the default is not desired, or the namespace requres you to set one. $xObj = $obj->NewChild("my:namespace"); $xObj = $obj->NewChild("my:namespace","foo"); ie. InsertRawXML(string) - puts the specified string raw into the XML packet that you call this on. $message->InsertRawXML("") ... $x = $message->NewChild(..); $x->InsertRawXML("test"); $query = $iq->GetChild(..); $query->InsertRawXML("test"); ClearRawXML() - removes the raw XML from the packet. =head2 Removal functions RemoveChild() - removes all of the namespaces child elements RemoveChild(namespace) from the object. If a namespace is provided, then only the children with that namespace are removed. =head2 Test functions DefinedChild() - returns 1 if there are any known namespaced DefinedChild(namespace) stanzas in the packet, 0 otherwise. Optionally you can specify a namespace and determine if there are any stanzas with that namespace. $test = $obj->DefinedChild(); $test = $obj->DefinedChild("my:namespace"); =head1 PACKAGES For more information on each of these packages, please see the man page for each one. =head2 Net::XMPP::Client This package contains the code needed to communicate with an XMPP server: login, wait for messages, send messages, and logout. It uses XML::Stream to read the stream from the server and based on what kind of tag it encounters it calls a function to handle the tag. =head2 Net::XMPP::Protocol A collection of high-level functions that Client uses to make their lives easier. These methods are inherited by the Client. =head2 Net::XMPP::JID The XMPP IDs consist of three parts: user id, server, and resource. This module gives you access to those components without having to parse the string yourself. =head2 Net::XMPP::Message Everything needed to create and read a received from the server. =head2 Net::XMPP::Presence Everything needed to create and read a received from the server. =head2 Net::XMPP::IQ IQ is a wrapper around a number of modules that provide support for the various Info/Query namespaces that XMPP recognizes. =head2 Net::XMPP::Stanza This module represents a namespaced stanza that is used to extend a , , and . The man page for Net::XMPP::Stanza contains a listing of all supported namespaces, and the methods that are supported by the objects that represent those namespaces. =head2 Net::XMPP::Namespaces XMPP allows for any stanza to be extended by any bit of XML. This module contains all of the internals for defining the XMPP based extensions defined by the IETF. The documentation for this module explains more about how to add your own custom namespace and have it be supported. =head1 AUTHOR Ryan Eatmon Currently maintained by Eric Hacker. =head1 BUGS Probably. There is at least one issue with XLM::Stream providing different node structures depending on how the node is created. Net::XMPP should now be able to handle this, but who knows what else lurks. =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut require 5.005; use strict; use XML::Stream 1.22 qw( Node ); use Time::Local; use Carp; use Digest::SHA1; use Authen::SASL; use MIME::Base64; use POSIX; use vars qw( $AUTOLOAD $VERSION $PARSING ); $VERSION = "1.02"; use Net::XMPP::Debug; use Net::XMPP::JID; use Net::XMPP::Namespaces; use Net::XMPP::Stanza; use Net::XMPP::Message; use Net::XMPP::IQ; use Net::XMPP::Presence; use Net::XMPP::Protocol; use Net::XMPP::Client; ############################################################################## # # printData - debugging function to print out any data structure in an # organized manner. Very useful for debugging XML::Parser::Tree # objects. This is a private function that will only exist in # in the development version. # ############################################################################## sub printData { print &sprintData(@_); } ############################################################################## # # sprintData - debugging function to build a string out of any data structure # in an organized manner. Very useful for debugging # XML::Parser::Tree objects and perl hashes of hashes. # # This is a private function. # ############################################################################## sub sprintData { return &XML::Stream::sprintData(@_); } ############################################################################## # # GetTimeStamp - generic funcion for getting a timestamp. # ############################################################################## sub GetTimeStamp { my($type,$time,$length) = @_; return "" if (($type ne "local") && ($type ne "utc") && !($type =~ /^(local|utc)delay(local|utc|time)$/)); $length = "long" unless defined($length); my ($sec,$min,$hour,$mday,$mon,$year,$wday); if ($type =~ /utcdelay/) { ($year,$mon,$mday,$hour,$min,$sec) = ($time =~ /^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)\:(\d\d)\:(\d\d)$/); $mon--; ($type) = ($type =~ /^utcdelay(.*)$/); $time = timegm($sec,$min,$hour,$mday,$mon,$year); } if ($type =~ /localdelay/) { ($year,$mon,$mday,$hour,$min,$sec) = ($time =~ /^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)\:(\d\d)\:(\d\d)$/); $mon--; ($type) = ($type =~ /^localdelay(.*)$/); $time = timelocal($sec,$min,$hour,$mday,$mon,$year); } return $time if ($type eq "time"); ($sec,$min,$hour,$mday,$mon,$year,$wday) = localtime(((defined($time) && ($time ne "")) ? $time : time)) if ($type eq "local"); ($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime(((defined($time) && ($time ne "")) ? $time : time)) if ($type eq "utc"); return sprintf("%d%02d%02dT%02d:%02d:%02d",($year + 1900),($mon+1),$mday,$hour,$min,$sec) if ($length eq "stamp"); $wday = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat')[$wday]; my $month = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec')[$mon]; $mon++; return sprintf("%3s %3s %02d, %d %02d:%02d:%02d",$wday,$month,$mday,($year + 1900),$hour,$min,$sec) if ($length eq "long"); return sprintf("%3s %d/%02d/%02d %02d:%02d",$wday,($year + 1900),$mon,$mday,$hour,$min) if ($length eq "normal"); return sprintf("%02d:%02d:%02d",$hour,$min,$sec) if ($length eq "short"); return sprintf("%02d:%02d",$hour,$min) if ($length eq "shortest"); } ############################################################################## # # GetHumanTime - convert seconds, into a human readable time string. # ############################################################################## sub GetHumanTime { my $seconds = shift; my $minutes = 0; my $hours = 0; my $days = 0; my $weeks = 0; while ($seconds >= 60) { $minutes++; if ($minutes == 60) { $hours++; if ($hours == 24) { $days++; if ($days == 7) { $weeks++; $days -= 7; } $hours -= 24; } $minutes -= 60; } $seconds -= 60; } my $humanTime; $humanTime .= "$weeks week " if ($weeks == 1); $humanTime .= "$weeks weeks " if ($weeks > 1); $humanTime .= "$days day " if ($days == 1); $humanTime .= "$days days " if ($days > 1); $humanTime .= "$hours hour " if ($hours == 1); $humanTime .= "$hours hours " if ($hours > 1); $humanTime .= "$minutes minute " if ($minutes == 1); $humanTime .= "$minutes minutes " if ($minutes > 1); $humanTime .= "$seconds second " if ($seconds == 1); $humanTime .= "$seconds seconds " if ($seconds > 1); $humanTime = "none" if ($humanTime eq ""); return $humanTime; } 1; XMPP000777000000000000 010603223625 15277 5ustar00unknownunknown000000000000Net-XMPP-1.02/lib/NetClient.pm000444000000000000 2275210602727502 17236 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::Client; =head1 NAME Net::XMPP::Client - XMPP Client Module =head1 SYNOPSIS Net::XMPP::Client is a module that provides a developer easy access to the Extensible Messaging and Presence Protocol (XMPP). =head1 DESCRIPTION Client.pm uses Protocol.pm to provide enough high level APIs and automation of the low level APIs that writing an XMPP Client in Perl is trivial. For those that wish to work with the low level you can do that too, but those functions are covered in the documentation for each module. Net::XMPP::Client provides functions to connect to an XMPP server, login, send and receive messages, set personal information, create a new user account, manage the roster, and disconnect. You can use all or none of the functions, there is no requirement. For more information on how the details for how Net::XMPP is written please see the help for Net::XMPP itself. For a full list of high level functions available please see Net::XMPP::Protocol. =head2 Basic Functions use Net::XMPP; $Con = new Net::XMPP::Client(); $Con->SetCallbacks(...); $Con->Execute(hostname=>"jabber.org", username=>"bob", password=>"XXXX", resource=>"Work' ); # # For the list of available functions see Net::XMPP::Protocol. # $Con->Disconnect(); =head1 METHODS =head2 Basic Functions new(debuglevel=>0|1|2, - creates the Client object. debugfile debugfile=>string, should be set to the path for the debug debugtime=>0|1) log to be written. If set to "stdout" then the debug will go there. debuglevel controls the amount of debug. For more information about the valid setting for debuglevel, debugfile, and debugtime see Net::XMPP::Debug. Connect(hostname=>string, - opens a connection to the server port=>integer, listed in the hostname (default timeout=>int localhost), on the port (default connectiontype=>string, 5222) listed, using the tls=>0|1) connectiontype listed (default tcpip). The two connection types available are: tcpip standard TCP socket http TCP socket, but with the headers needed to talk through a web proxy If you specify tls, then it TLS will be used if it is available as a feature. Execute(hostname=>string, - Generic inner loop to handle port=>int, connecting to the server, calling tls=>0|1, Process, and reconnecting if the username=>string, connection is lost. There are password=>string, five callbacks available that are resource=>string, called at various places: register=>0|1, onconnect - when the client has connectiontype=>string, made a connection. connecttimeout=>string, onauth - when the connection is connectattempts=>int, made and user has been connectsleep=>int, authed. Essentially, processtimeout=>int) this is when you can start doing things as a Client. Like send presence, get your roster, etc... onprocess - this is the most inner loop and so gets called the most. Be very very careful what you put here since it can *DRASTICALLY* affect performance. ondisconnect - when the client disconnects from the server. onexit - when the function gives up trying to connect and exits. The arguments are passed straight on to the Connect function, except for connectattempts and connectsleep. connectattempts is the number of times that the Component should try to connect before giving up. -1 means try forever. The default is -1. connectsleep is the number of seconds to sleep between each connection attempt. If you specify register=>1, then the Client will attempt to register the sepecified account for you, if it does not exist. Process(integer) - takes the timeout period as an argument. If no timeout is listed then the function blocks until a packet is received. Otherwise it waits that number of seconds and then exits so your program can continue doing useful things. NOTE: This is important for GUIs. You need to leave time to process GUI commands even if you are waiting for packets. The following are the possible return values, and what they mean: 1 - Status ok, data received. 0 - Status ok, no data received. undef - Status not ok, stop processing. IMPORTANT: You need to check the output of every Process. If you get an undef then the connection died and you should behave accordingly. Disconnect() - closes the connection to the server. Connected() - returns 1 if the Transport is connected to the server, and 0 if not. =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut use strict; use Carp; use Net::XMPP::Connection; use base qw( Net::XMPP::Connection ); sub new { my $proto = shift; my $self = { }; bless($self, $proto); $self->init(@_); $self->{SERVER}->{port} = 5222; $self->{SERVER}->{namespace} = "jabber:client"; $self->{SERVER}->{allow_register} = 1; return $self; } sub _auth { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my %auth; $auth{username} = $args{username}; $auth{password} = $args{password}; $auth{resource} = $args{resource} if exists($args{resource}); return $self->AuthSend(%auth); } sub _connection_args { my $self = shift; my (%args) = @_; my %connect; $connect{hostname} = $args{hostname}; $connect{port} = $args{port} if exists($args{port}); $connect{connectiontype} = $args{connectiontype} if exists($args{connectiontype}); $connect{timeout} = $args{connecttimeout} if exists($args{connecttimeout}); $connect{tls} = $args{tls} if exists($args{tls}); return %connect; } sub _register { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my %fields = $self->RegisterRequest(); $fields{username} = $args{username}; $fields{password} = $args{password}; $self->RegisterSend(%fields); return $self->_auth(%args); } 1; Connection.pm000444000000000000 3530710602727530 20120 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::Connection; =head1 NAME Net::XMPP::Connection - XMPP Connection Module =head1 SYNOPSIS Net::XMPP::Connection is a private package that serves as a basis for anything wanting to open a socket connection to a server. =head1 DESCRIPTION This module is not meant to be used directly. You should be using either Net::XMPP::Client, or another package that inherits from Net::XMPP::Connection. =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut use strict; use Carp; use base qw( Net::XMPP::Protocol ); sub new { my $proto = shift; my $self = { }; bless($self, $proto); $self->init(@_); $self->{SERVER}->{namespace} = "unknown"; return $self; } ############################################################################## # # init - do all of the heavy lifting for a generic connection. # ############################################################################## sub init { my $self = shift; $self->{ARGS} = {}; while($#_ >= 0) { $self->{ARGS}->{ lc(pop(@_)) } = pop(@_); } $self->{DEBUG} = new Net::XMPP::Debug(level => $self->_arg("debuglevel",-1), file => $self->_arg("debugfile","stdout"), time => $self->_arg("debugtime",0), setdefault => 1, header => "XMPP::Conn" ); $self->{SERVER} = {}; $self->{SERVER}->{hostname} = "localhost"; $self->{SERVER}->{tls} = $self->_arg("tls",0); $self->{SERVER}->{ssl} = $self->_arg("ssl",0); $self->{SERVER}->{connectiontype} = $self->_arg("connectiontype","tcpip"); $self->{CONNECTED} = 0; $self->{DISCONNECTED} = 0; $self->{STREAM} = new XML::Stream(style => "node", debugfh => $self->{DEBUG}->GetHandle(), debuglevel => $self->{DEBUG}->GetLevel(), debugtime => $self->{DEBUG}->GetTime(), ); $self->{RCVDB}->{currentID} = 0; $self->InitCallbacks(); return $self; } ############################################################################## # # Connect - Takes a has and opens the connection to the specified server. # Registers CallBack as the main callback for all packets from # the server. # # NOTE: Need to add some error handling if the connection is # not made because the server hostname is wrong or whatnot. # ############################################################################## sub Connect { my $self = shift; while($#_ >= 0) { $self->{SERVER}{ lc pop(@_) } = pop(@_); } $self->{SERVER}->{timeout} = 10 unless exists($self->{SERVER}->{timeout}); $self->{DEBUG}->Log1("Connect: host($self->{SERVER}->{hostname}:$self->{SERVER}->{port}) namespace($self->{SERVER}->{namespace})"); $self->{DEBUG}->Log1("Connect: timeout($self->{SERVER}->{timeout})"); delete($self->{SESSION}); $self->{SESSION} = $self->{STREAM}-> Connect(hostname => $self->{SERVER}->{hostname}, port => $self->{SERVER}->{port}, namespace => $self->{SERVER}->{namespace}, connectiontype => $self->{SERVER}->{connectiontype}, timeout => $self->{SERVER}->{timeout}, ssl => $self->{SERVER}->{ssl}, #LEGACY (defined($self->{SERVER}->{componentname}) ? (to => $self->{SERVER}->{componentname}) : () ), ); if ($self->{SESSION}) { $self->{DEBUG}->Log1("Connect: connection made"); $self->{STREAM}->SetCallBacks(node=>sub{ $self->CallBack(@_) }); $self->{CONNECTED} = 1; $self->{RECONNECTING} = 0; if (exists($self->{SESSION}->{version}) && ($self->{SESSION}->{version} ne "")) { my $tls = $self->GetStreamFeature("xmpp-tls"); if (defined($tls) && $self->{SERVER}->{tls}) { $self->{SESSION} = $self->{STREAM}->StartTLS( $self->{SESSION}->{id}, $self->{SERVER}->{timeout}, ); } elsif (defined($tls) && ($tls eq "required")) { $self->SetErrorCode("The server requires us to use TLS, but you did not specify that\nTLS was an option."); return; } } return 1; } else { $self->SetErrorCode($self->{STREAM}->GetErrorCode()); return; } } ############################################################################## # # Connected - returns 1 if the Transport is connected to the server, 0 # otherwise. # ############################################################################## sub Connected { my $self = shift; $self->{DEBUG}->Log1("Connected: ($self->{CONNECTED})"); return $self->{CONNECTED}; } ############################################################################## # # Disconnect - Sends the string to close the connection cleanly. # ############################################################################## sub Disconnect { my $self = shift; $self->{STREAM}->Disconnect($self->{SESSION}->{id}) if ($self->{CONNECTED} == 1); $self->{STREAM}->SetCallBacks(node=>undef); $self->{CONNECTED} = 0; $self->{DISCONNECTED} = 1; $self->{RECONNECTING} = 0; $self->{DEBUG}->Log1("Disconnect: bye bye"); } ############################################################################## # # Execute - generic inner loop to listen for incoming messages, stay # connected to the server, and do all the right things. It # calls a couple of callbacks for the user to put hooks into # place if they choose to. # ############################################################################## sub Execute { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $args{connectiontype} = "tcpip" unless exists($args{connectiontype}); $args{connectattempts} = -1 unless exists($args{connectattempts}); $args{connectsleep} = 5 unless exists($args{connectsleep}); $args{register} = 0 unless exists($args{register}); my %connect = $self->_connect_args(%args); $self->{DEBUG}->Log1("Execute: begin"); my $connectAttempt = $args{connectattempts}; while(($connectAttempt == -1) || ($connectAttempt > 0)) { $self->{DEBUG}->Log1("Execute: Attempt to connect ($connectAttempt)"); my $status = $self->Connect(%connect); if (!(defined($status))) { $self->{DEBUG}->Log1("Execute: Server is not answering. (".$self->GetErrorCode().")"); $self->{CONNECTED} = 0; $connectAttempt-- unless ($connectAttempt == -1); sleep($args{connectsleep}); next; } $self->{DEBUG}->Log1("Execute: Connected..."); &{$self->{CB}->{onconnect}}() if exists($self->{CB}->{onconnect}); my @result = $self->_auth(%args); if (@result && $result[0] ne "ok") { $self->{DEBUG}->Log1("Execute: Could not auth with server: ($result[0]: $result[1])"); &{$self->{CB}->{onauthfail}}() if exists($self->{CB}->{onauthfail}); if (!$self->{SERVER}->{allow_register} || $args{register} == 0) { $self->{DEBUG}->Log1("Execute: Register turned off. Exiting."); $self->Disconnect(); &{$self->{CB}->{ondisconnect}}() if exists($self->{CB}->{ondisconnect}); $connectAttempt = 0; } else { @result = $self->_register(%args); if ($result[0] ne "ok") { $self->{DEBUG}->Log1("Execute: Register failed. Exiting."); &{$self->{CB}->{onregisterfail}}() if exists($self->{CB}->{onregisterfail}); $self->Disconnect(); &{$self->{CB}->{ondisconnect}}() if exists($self->{CB}->{ondisconnect}); $connectAttempt = 0; } else { &{$self->{CB}->{onauth}}() if exists($self->{CB}->{onauth}); } } } else { &{$self->{CB}->{onauth}}() if exists($self->{CB}->{onauth}); } while($self->Connected()) { while(defined($status = $self->Process($args{processtimeout}))) { &{$self->{CB}->{onprocess}}() if exists($self->{CB}->{onprocess}); } if (!defined($status)) { $self->Disconnect(); $self->{RECONNECTING} = 1; delete($self->{PROCESSERROR}); $self->{DEBUG}->Log1("Execute: Connection to server lost..."); &{$self->{CB}->{ondisconnect}}() if exists($self->{CB}->{ondisconnect}); $connectAttempt = $args{connectattempts}; next; } } last if (!$self->{RECONNECTING} && $self->{DISCONNECTED}); } $self->{DEBUG}->Log1("Execute: end"); &{$self->{CB}->{onexit}}() if exists($self->{CB}->{onexit}); } ############################################################################## # # InitCallbacks - initialize the callbacks # ############################################################################## sub InitCallbacks { my $self = shift; $self->xmppCallbackInit(); } ############################################################################### # # Process - If a timeout value is specified then the function will wait # that long before returning. This is useful for apps that # need to handle other processing while still waiting for # packets. If no timeout is listed then the function waits # until a packet is returned. Either way the function exits # as soon as a packet is returned. # ############################################################################### sub Process { my $self = shift; my ($timeout) = @_; my %status; if (exists($self->{PROCESSERROR}) && ($self->{PROCESSERROR} == 1)) { croak("There was an error in the last call to Process that you did not check for and\nhandle. You should always check the output of the Process call. If it was\nundef then there was a fatal error that you need to check. There is an error\nin your program"); } $self->{DEBUG}->Log1("Process: timeout($timeout)") if defined($timeout); if (!defined($timeout) || ($timeout eq "")) { while(1) { %status = $self->{STREAM}->Process(); $self->{DEBUG}->Log1("Process: status($status{$self->{SESSION}->{id}})"); last if ($status{$self->{SESSION}->{id}} != 0); select(undef,undef,undef,.25); } $self->{DEBUG}->Log1("Process: return($status{$self->{SESSION}->{id}})"); if ($status{$self->{SESSION}->{id}} == -1) { $self->{PROCESSERROR} = 1; return; } else { return $status{$self->{SESSION}->{id}}; } } else { %status = $self->{STREAM}->Process($timeout); if ($status{$self->{SESSION}->{id}} == -1) { $self->{PROCESSERROR} = 1; return; } else { return $status{$self->{SESSION}->{id}}; } } } ############################################################################## #+---------------------------------------------------------------------------- #| #| Overloadable Methods #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # _auth - Overload this method to provide the authentication method for your # type of connection. # ############################################################################## sub _auth { my $self = shift; croak("You must override the _auth method."); } ############################################################################## # # _connect_args - The Connect function that the Execute loop uses needs # certain args. This method lets you map the Execute args # into the Connect args for your Connection type. # ############################################################################## sub _connect_args { my $self = shift; my (%args) = @_; return %args; } ############################################################################## # # _register - overload this method if you need your connection to register # with the server. # ############################################################################## sub _register { my $self = shift; return ( "ok" ,"" ); } ############################################################################## #+---------------------------------------------------------------------------- #| #| Private Helpers #| #+---------------------------------------------------------------------------- ############################################################################## sub _arg { my $self = shift; my $arg = shift; my $default = shift; return exists($self->{ARGS}->{$arg}) ? $self->{ARGS}->{$arg} : $default; } 1; Debug.pm000444000000000000 2452310602727561 17051 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::Debug; =head1 NAME Net::XMPP::Debug - XMPP Debug Module =head1 SYNOPSIS Net::XMPP::Debug is a module that provides a developer easy access to logging debug information. =head1 DESCRIPTION Debug is a helper module for the Net::XMPP modules. It provides the Net::XMPP modules with an object to control where, how, and what is logged. =head2 Basic Functions $Debug = new Net::XMPP::Debug(); $Debug->Init(level=>2, file=>"stdout", header=>"MyScript"); $Debug->Log0("Connection established"); =head1 METHODS =head2 Basic Functions new(hash) - creates the Debug object. The hash argument is passed to the Init function. See that function description below for the valid settings. Init(level=>integer, - initializes the debug object. The level file=>string, determines the maximum level of debug header=>string, messages to log: setdefault=>0|1, 0 - Base level Output (default) usedefault=>0|1, 1 - High level API calls time=>0|1) 2 - Low level API calls ... N - Whatever you want.... The file determines where the debug log goes. You can either specify a path to a file, or "stdout" (the default). "stdout" tells Debug to send all of the debug info sent to this object to go to stdout. header is a string that will preappended to the beginning of all log entries. This makes it easier to see what generated the log entry (default is "Debug"). setdefault saves the current filehandle and makes it available for other Debug objects to use. To use the default set usedefault to 1. The time parameter specifies whether or not to add a timestamp to the beginning of each logged line. LogN(array) - Logs the elements of the array at the corresponding debug level N. If you pass in a reference to an array or hash then they are printed in a readable way. (ie... Log0, Log2, Log100, etc...) =head1 EXAMPLE $Debug = new Net::XMPP:Debug(level=>2, header=>"Example"); $Debug->Log0("test"); $Debug->Log2("level 2 test"); $hash{a} = "atest"; $hash{b} = "btest"; $Debug->Log1("hashtest",\%hash); You would get the following log: Example: test Example: level 2 test Example: hashtest { a=>"atest" b=>"btest" } If you had set the level to 1 instead of 2 you would get: Example: test Example: hashtest { a=>"atest" b=>"btest" } =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut require 5.003; use strict; use FileHandle; use Carp; use vars qw( %HANDLES $DEFAULT $DEFAULTLEVEL $DEFAULTTIME $AUTOLOAD ); $DEFAULTLEVEL = -1; sub new { my $proto = shift; my $self = { }; bless($self, $proto); $self->Init(@_); return $self; } ############################################################################## # # Init - opens the fielhandle and initializes the Debug object. # ############################################################################## sub Init { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } delete($args{file}) if (lc($args{file}) eq "stdout"); $args{time} = 0 if !exists($args{time}); $args{setdefault} = 0 if !exists($args{setdefault}); $args{usedefault} = 0 if !exists($args{usedefault}); $self->{TIME} = $args{time}; if ($args{usedefault} == 1) { $args{setdefault} = 0; $self->{USEDEFAULT} = 1; } else { $self->{LEVEL} = 0; $self->{LEVEL} = $args{level} if exists($args{level}); $self->{HANDLE} = new FileHandle(">&STDERR"); $self->{HANDLE}->autoflush(1); if (exists($args{file})) { if (exists($Net::XMPP::Debug::HANDLES{$args{file}})) { $self->{HANDLE} = $Net::XMPP::Debug::HANDLES{$args{file}}; $self->{HANDLE}->autoflush(1); } else { if (-e $args{file}) { if (-w $args{file}) { $self->{HANDLE} = new FileHandle(">$args{file}"); if (defined($self->{HANDLE})) { $self->{HANDLE}->autoflush(1); $Net::XMPP::Debug::HANDLES{$args{file}} = $self->{HANDLE}; } else { print STDERR "ERROR: Debug filehandle could not be opened.\n"; print STDERR" Debugging disabled.\n"; print STDERR " ($!)\n"; $self->{LEVEL} = -1; } } else { print STDERR "ERROR: You do not have permission to write to $args{file}.\n"; print STDERR" Debugging disabled.\n"; $self->{LEVEL} = -1; } } else { $self->{HANDLE} = new FileHandle(">$args{file}"); if (defined($self->{HANDLE})) { $self->{HANDLE}->autoflush(1); $Net::XMPP::Debug::HANDLES{$args{file}} = $self->{HANDLE}; } else { print STDERR "ERROR: Debug filehandle could not be opened.\n"; print STDERR" Debugging disabled.\n"; print STDERR " ($!)\n"; $self->{LEVEL} = -1; } } } } } if ($args{setdefault} == 1) { $Net::XMPP::Debug::DEFAULT = $self->{HANDLE}; $Net::XMPP::Debug::DEFAULTLEVEL = $self->{LEVEL}; $Net::XMPP::Debug::DEFAULTTIME = $self->{TIME}; } $self->{HEADER} = "Debug"; $self->{HEADER} = $args{header} if exists($args{header}); } ############################################################################## # # Log - takes the limit and the array to log and logs them # ############################################################################## sub Log { my $self = shift; my (@args) = @_; my $fh = $self->{HANDLE}; $fh = $Net::XMPP::Debug::DEFAULT if exists($self->{USEDEFAULT}); my $string = ""; my $testTime = $self->{TIME}; $testTime = $Net::XMPP::Debug::DEFAULTTIME if exists($self->{USEDEFAULT}); $string .= "[".&Net::XMPP::GetTimeStamp("local",time,"short")."] " if ($testTime == 1); $string .= $self->{HEADER}.": "; my $arg; foreach $arg (@args) { if (ref($arg) eq "HASH") { $string .= " {"; my $key; foreach $key (sort {$a cmp $b} keys(%{$arg})) { $string .= " ".$key."=>'".$arg->{$key}."'"; } $string .= " }"; } else { if (ref($arg) eq "ARRAY") { $string .= " [ ".join(" ",@{$arg})." ]"; } else { $string .= $arg; } } } print $fh "$string\n"; return 1; } ############################################################################## # # AUTOLOAD - if a function is called that is not defined then this function # will examine the function name and either give an error or call # the appropriate function. # ############################################################################## sub AUTOLOAD { my $self = shift; return if ($AUTOLOAD =~ /::DESTROY$/); my ($function) = ($AUTOLOAD =~ /\:\:(.*)$/); croak("$function not defined") if !($function =~ /Log\d+/); my ($level) = ($function =~ /Log(\d+)/); return 0 if ($level > (exists($self->{USEDEFAULT}) ? $Net::XMPP::Debug::DEFAULTLEVEL : $self->{LEVEL})); $self->Log(@_); } ############################################################################## # # GetHandle - returns the filehandle being used by this object. # ############################################################################## sub GetHandle { my $self = shift; return $self->{HANDLE}; } ############################################################################## # # GetLevel - returns the debug level used by this object. # ############################################################################## sub GetLevel { my $self = shift; return $self->{LEVEL}; } ############################################################################## # # GetTime - returns the debug time used by this object. # ############################################################################## sub GetTime { my $self = shift; return $self->{TIME}; } 1; IQ.pm000444000000000000 2606710602727610 16334 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::IQ; =head1 NAME Net::XMPP::IQ - XMPP Info/Query Module =head1 SYNOPSIS Net::XMPP::IQ is a companion to the Net::XMPP module. It provides the user a simple interface to set and retrieve all parts of an XMPP IQ. =head1 DESCRIPTION Net::XMPP::IQ differs from the other Net::XMPP::* modules in that the XMLNS of the query is split out into a submodule under IQ. For specifics on each module please view the documentation for the Net::XMPP::Namespaces module. A Net::XMPP::IQ object is passed to the callback function for the message. Also, the first argument to the callback functions is the session ID from XML::Stream. There are some cases where you might want this information, like if you created a Client that connects to two servers at once, or for writing a mini server. use Net::XMPP; sub iq { my ($sid,$IQ) = @_; . . my $reply = $IQ->Reply(); my $replyQuery->GetQuery(); . } You now have access to all of the retrieval functions available. To create a new iq to send to the server: use Net::XMPP; $IQ = new Net::XMPP::IQ(); $IQType = $IQ->NewChild( type ); $IQType->SetXXXXX("yyyyy"); Now you can call the creation functions for the IQ, and for the on the new query object itself. See below for the functions, and in each query module for those functions. =head1 METHODS =head2 General functions Reply(%args) - Creates a return with the to and from filled in correctly, and a query object already added in. The %args that you pass are passed to SetIQ() and will overwrite the IQ settings that Reply sets. =head2 Retrieval functions GetTo() - returns either a string with the JID, or a GetTo("jid") Net::XMPP::JID object for the person who is going to receive the . To get the JID object set the string to "jid", otherwise leave blank for the text string. $to = $IQ->GetTo(); $toJID = $IQ->GetTo("jid"); GetFrom() - returns either a string with the JID, or a GetFrom("jid") Net::XMPP::JID object for the person who sent the . To get the JID object set the string to "jid", otherwise leave blank for the text string. $from = $IQ->GetFrom(); $fromJID = $IQ->GetFrom("jid"); GetType() - returns a string with the type this is. $type = $IQ->GetType(); GetID() - returns an integer with the id of the . $id = $IQ->GetID(); GetError() - returns a string with the text description of the error. $error = $IQ->GetError(); GetErrorCode() - returns a string with the code of error. $errorCode = $IQ->GetErrorCode(); GetQuery() - returns a Net::XMPP::Stanza object that contains the data in the query of the . Basically, it returns the first child in the . $query = $IQ->GetQuery(); GetQueryXMLNS() - returns a string with the namespace of the query for this , if one exists. $xmlns = $IQ->GetQueryXMLNS(); =head2 Creation functions SetIQ(to=>string|JID, - set multiple fields in the at one from=>string|JID, time. This is a cumulative and over id=>string, writing action. If you set the "to" type=>string, attribute twice, the second setting is errorcode=>string, what is used. If you set the status, and error=>string) then set the priority then both will be in the tag. For valid settings read the specific Set functions below. $IQ->SetIQ(type=>"get", to=>"bob\@jabber.org"); $IQ->SetIQ(to=>"bob\@jabber.org", errorcode=>403, error=>"Permission Denied"); SetTo(string) - sets the to attribute. You can either pass a string SetTo(JID) or a JID object. They must be a valid Jabber Identifiers or the server will return an error message. (ie. bob@jabber.org, etc...) $IQ->SetTo("bob\@jabber.org"); SetFrom(string) - sets the from attribute. You can either pass a SetFrom(JID) string or a JID object. They must be a valid JIDs or the server will return an error message. (ie. bob@jabber.org, etc...) $IQ->SetFrom("me\@jabber.org"); SetType(string) - sets the type attribute. Valid settings are: get request information set set information result results of a get error there was an error $IQ->SetType("set"); SetErrorCode(string) - sets the error code of the . $IQ->SetErrorCode(403); SetError(string) - sets the error string of the . $IQ->SetError("Permission Denied"); NewChild(string) - creates a new Net::XMPP::Stanza object with the namespace in the string. In order for this function to work with a custom namespace, you must define and register that namespace with the IQ module. For more information please read the documentation for Net::XMPP::Stanza. $queryObj = $IQ->NewChild("jabber:iq:auth"); $queryObj = $IQ->NewChild("jabber:iq:roster"); Reply(hash) - creates a new IQ object and populates the to/from fields. If you specify a hash the same as with SetIQ then those values will override the Reply values. $iqReply = $IQ->Reply(); $iqReply = $IQ->Reply(type=>"result"); =head2 Removal functions RemoveTo() - removes the to attribute from the . $IQ->RemoveTo(); RemoveFrom() - removes the from attribute from the . $IQ->RemoveFrom(); RemoveID() - removes the id attribute from the . $IQ->RemoveID(); RemoveType() - removes the type attribute from the . $IQ->RemoveType(); RemoveError() - removes the element from the . $IQ->RemoveError(); RemoveErrorCode() - removes the code attribute from the element in the . $IQ->RemoveErrorCode(); =head2 Test functions DefinedTo() - returns 1 if the to attribute is defined in the , 0 otherwise. $test = $IQ->DefinedTo(); DefinedFrom() - returns 1 if the from attribute is defined in the , 0 otherwise. $test = $IQ->DefinedFrom(); DefinedID() - returns 1 if the id attribute is defined in the , 0 otherwise. $test = $IQ->DefinedID(); DefinedType() - returns 1 if the type attribute is defined in the , 0 otherwise. $test = $IQ->DefinedType(); DefinedError() - returns 1 if is defined in the , 0 otherwise. $test = $IQ->DefinedError(); DefinedErrorCode() - returns 1 if the code attribute is defined in , 0 otherwise. $test = $IQ->DefinedErrorCode(); DefinedQuery() - returns 1 if there is at least one namespaced child in the object. =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut require 5.003; use strict; use Carp; use vars qw( %FUNCTIONS ); use Net::XMPP::Stanza; use base qw( Net::XMPP::Stanza ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { }; bless($self, $proto); $self->{DEBUGHEADER} = "IQ"; $self->{TAG} = "iq"; $self->{FUNCS} = \%FUNCTIONS; $self->_init(@_); return $self; } sub _iq { my $self = shift; return new Net::XMPP::IQ(); } $FUNCTIONS{Error}->{path} = 'error/text()'; $FUNCTIONS{ErrorCode}->{path} = 'error/@code'; $FUNCTIONS{From}->{type} = 'jid'; $FUNCTIONS{From}->{path} = '@from'; $FUNCTIONS{ID}->{path} = '@id'; $FUNCTIONS{To}->{type} = 'jid'; $FUNCTIONS{To}->{path} = '@to'; $FUNCTIONS{Type}->{path} = '@type'; $FUNCTIONS{XMLNS}->{path} = '@xmlns'; $FUNCTIONS{IQ}->{type} = 'master'; $FUNCTIONS{Child}->{type} = 'child'; $FUNCTIONS{Child}->{path} = '*[@xmlns]'; $FUNCTIONS{Child}->{child} = { }; $FUNCTIONS{Query}->{type} = 'child'; $FUNCTIONS{Query}->{path} = '*[@xmlns][0]'; $FUNCTIONS{Query}->{child} = { child_index=>0 }; ############################################################################## # # GetQueryXMLNS - returns the xmlns of the first child # ############################################################################## sub GetQueryXMLNS { my $self = shift; return $self->{CHILDREN}->[0]->GetXMLNS() if ($#{$self->{CHILDREN}} > -1); } ############################################################################## # # Reply - returns a Net::XMPP::IQ object with the proper fields # already populated for you. # ############################################################################## sub Reply { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $reply = $self->_iq(); $reply->SetID($self->GetID()) if ($self->GetID() ne ""); $reply->SetType("result"); $reply->NewChild($self->GetQueryXMLNS()); $reply->SetIQ((($self->GetFrom() ne "") ? (to=>$self->GetFrom()) : () ), (($self->GetTo() ne "") ? (from=>$self->GetTo()) : () ), ); $reply->SetIQ(%args); return $reply; } 1; JID.pm000444000000000000 2355410602727636 16437 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::JID; =head1 NAME Net::XMPP::JID - XMPP JID Module =head1 SYNOPSIS Net::XMPP::JID is a companion to the Net::XMPP module. It provides the user a simple interface to set and retrieve all parts of a Jabber ID (userid on a server). =head1 DESCRIPTION To initialize the JID you must pass it the string that represents the jid from the XML packet. Inside the XMPP modules this is done automatically and the JID object is returned instead of a string. For example, in the callback function for the XMPP object foo: use Net::XMPP; sub foo { my $foo = new Net::XMPP::Foo(@_); my $from = $foo->GetFrom(); my $JID = new Net::XMPP::JID($from); . . . } You now have access to all of the retrieval functions available. To create a new JID to send to the server: use Net::XMPP; $JID = new Net::XMPP::JID(); Now you can call the creation functions below to populate the tag before sending it. =head2 Retrieval functions $userid = $JID->GetUserID(); $server = $JID->GetServer(); $resource = $JID->GetResource(); $JID = $JID->GetJID(); $fullJID = $JID->GetJID("full"); $baseJID = $JID->GetJID("base"); =head2 Creation functions $JID->SetJID(userid=>"bob", server=>"jabber.org", resource=>"Work"); $JID->SetJID('blue@moon.org/Home'); $JID->SetUserID("foo"); $JID->SetServer("bar.net"); $JID->SetResource("Foo Bar"); =head1 METHODS =head2 Retrieval functions GetUserID() - returns a string with the userid of the JID. If the string is an address (bob%jabber.org) then the function will return it as an address (bob@jabber.org). GetServer() - returns a string with the server of the JID. GetResource() - returns a string with the resource of the JID. GetJID() - returns a string that represents the JID stored GetJID("full") within. If the "full" string is specified, then GetJID("base") you get the full JID, including Resource, which should be used to send to the server. If the "base", string is specified, then you will just get user@server, or the base JID. =head2 Creation functions SetJID(userid=>string, - set multiple fields in the jid at server=>string, one time. This is a cumulative resource=>string) and over writing action. If you set SetJID(string) the "userid" attribute twice, the second setting is what is used. If you set the server, and then set the resource then both will be in the jid. If all you pass is a string, then that string is used as the JID. For valid settings read the specific Set functions below. SetUserID(string) - sets the userid. Must be a valid userid or the server will complain if you try to use this JID to talk to the server. If the string is an address then it will be converted to the % form suitable for using as a User ID. SetServer(string) - sets the server. Must be a valid host on the network or the server will not be able to talk to it. SetResource(string) - sets the resource of the userid to talk to. =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut require 5.003; use strict; use Carp; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { }; bless($self, $proto); if ("@_" ne ("")) { my ($jid) = @_; return $jid if ((ref($jid) ne "") && ($jid->isa("Net::XMPP::JID"))); $self->{JID} = $jid; } else { $self->{JID} = ""; } $self->ParseJID(); return $self; } ############################################################################## # # ParseJID - private helper function that takes the JID and sets the # the three parts of it. # ############################################################################## sub ParseJID { my $self = shift; my $userid; my $server; my $resource; ($userid,$server,$resource) = ($self->{JID} =~ /^([^\@\/'"&:<>]*)\@([A-Za-z0-9\.\-\_]+)\/?(.*?)$/); if (!defined($server)) { ($server,$resource) = ($self->{JID} =~ /^([A-Za-z0-9\.\-\_]+)\/?(.*?)$/); } $userid = "" unless defined($userid); $server = "" unless defined($server); $resource = "" unless defined($resource); $self->{USERID} = $userid; $self->{SERVER} = $server; $self->{RESOURCE} = $resource; } ############################################################################## # # BuildJID - private helper function that takes the three parts and sets the # JID from them. # ############################################################################## sub BuildJID { my $self = shift; $self->{JID} = $self->{USERID}; $self->{JID} .= "\@" if ($self->{USERID} ne ""); $self->{JID} .= $self->{SERVER} if (exists($self->{SERVER}) && defined($self->{SERVER})); $self->{JID} .= "/".$self->{RESOURCE} if (exists($self->{RESOURCE}) && defined($self->{RESOURCE}) && ($self->{RESOURCE} ne "")); } ############################################################################## # # GetUserID - returns the userid of the JID. # ############################################################################## sub GetUserID { my $self = shift; my $userid = $self->{USERID}; $userid =~ s/\%/\@/; return $userid; } ############################################################################## # # GetServer - returns the server of the JID. # ############################################################################## sub GetServer { my $self = shift; return $self->{SERVER}; } ############################################################################## # # GetResource - returns the resource of the JID. # ############################################################################## sub GetResource { my $self = shift; return $self->{RESOURCE}; } ############################################################################## # # GetJID - returns the full jid of the JID. # ############################################################################## sub GetJID { my $self = shift; my $type = shift; $type = "" unless defined($type); return $self->{JID} if ($type eq "full"); return $self->{USERID}."\@".$self->{SERVER} if ($self->{USERID} ne ""); return $self->{SERVER}; } ############################################################################## # # SetJID - takes a hash of all of the things you can set on a JID and sets # each one. # ############################################################################## sub SetJID { my $self = shift; my %jid; if ($#_ > 0 ) { while($#_ >= 0) { $jid{ lc pop(@_) } = pop(@_); } $self->SetUserID($jid{userid}) if exists($jid{userid}); $self->SetServer($jid{server}) if exists($jid{server}); $self->SetResource($jid{resource}) if exists($jid{resource}); } else { ($self->{JID}) = @_; $self->ParseJID(); } } ############################################################################## # # SetUserID - sets the userid of the JID. # ############################################################################## sub SetUserID { my $self = shift; my ($userid) = @_; $userid =~ s/\@/\%/; $self->{USERID} = $userid; $self->BuildJID(); } ############################################################################## # # SetServer - sets the server of the JID. # ############################################################################## sub SetServer { my $self = shift; my ($server) = @_; $self->{SERVER} = $server; $self->BuildJID(); } ############################################################################## # # SetResource - sets the resource of the JID. # ############################################################################## sub SetResource { my $self = shift; my ($resource) = @_; $self->{RESOURCE} = $resource; $self->BuildJID(); } ############################################################################## # # debug - prints out the contents of the JID # ############################################################################## sub debug { my $self = shift; print "debug JID: $self\n"; print "UserID: (",$self->{USERID},")\n"; print "Server: (",$self->{SERVER},")\n"; print "Resource: (",$self->{RESOURCE},")\n"; print "JID: (",$self->{JID},")\n"; } 1; Message.pm000444000000000000 3172710602727657 17421 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::Message; =head1 NAME Net::XMPP::Message - XMPP Message Module =head1 SYNOPSIS Net::XMPP::Message is a companion to the Net::XMPP module. It provides the user a simple interface to set and retrieve all parts of an XMPP Message. =head1 DESCRIPTION A Net::XMPP::Message object is passed to the callback function for the message. Also, the first argument to the callback functions is the session ID from XML::Stream. There are some cases where you might want thisinformation, like if you created a Client that connects to two servers at once, or for writing a mini server. use Net::XMPP; sub message { my ($sid,$Mess) = @_; . . . } You now have access to all of the retrieval functions available. To create a new message to send to the server: use Net::XMPP; $Mess = new Net::XMPP::Message(); Now you can call the creation functions below to populate the tag before sending it. =head1 METHODS =head2 Retrieval functions GetTo() - returns the value in the to='' attribute for the GetTo("jid") . If you specify "jid" as an argument then a Net::XMPP::JID object is returned and you can easily parse the parts of the JID. $to = $Mess->GetTo(); $toJID = $Mess->GetTo("jid"); GetFrom() - returns the value in the from='' attribute for the GetFrom("jid") . If you specify "jid" as an argument then a Net::XMPP::JID object is returned and you can easily parse the parts of the JID. $from = $Mess->GetFrom(); $fromJID = $Mess->GetFrom("jid"); GetType() - returns the type='' attribute of the . Each message is one of four types: normal regular message (default if type is blank) chat one on one chat groupchat multi-person chat headline headline error error message $type = $Mess->GetType(); GetSubject() - returns the data in the tag. $subject = $Mess->GetSubject(); GetBody() - returns the data in the tag. $body = $Mess->GetBody(); GetThread() - returns the data in the tag. $thread = $Mess->GetThread(); GetError() - returns a string with the data of the tag. $error = $Mess->GetError(); GetErrorCode() - returns a string with the code='' attribute of the tag. $errCode = $Mess->GetErrorCode(); GetTimeStamp() - returns a string that represents the time this message object was created (and probably received) for sending to the client. If there is a jabber:x:delay tag then that time is used to show when the message was sent. $date = $Mess->GetTimeStamp(); =head2 Creation functions SetMessage(to=>string|JID, - set multiple fields in the from=>string|JID, at one time. This is a cumulative type=>string, and over writing action. If you set subject=>string, the "to" attribute twice, the second body=>string, setting is what is used. If you set thread=>string, the subject, and then set the body errorcode=>string, then both will be in the error=>string) tag. For valid settings read the specific Set functions below. $Mess->SetMessage(TO=>"bob\@jabber.org", Subject=>"Lunch", BoDy=>"Let's do lunch!"); $Mess->SetMessage(to=>"bob\@jabber.org", from=>"jabber.org", errorcode=>404, error=>"Not found"); SetTo(string) - sets the to='' attribute. You can either pass SetTo(JID) a string or a JID object. They must be valid JIDs or the server will return an error message. (ie. bob@jabber.org/Work) $Mess->SetTo("test\@jabber.org"); SetFrom(string) - sets the from='' attribute. You can either pass SetFrom(JID) a string or a JID object. They must be valid JIDs or the server will return an error message. (ie. jabber:bob@jabber.org/Work) This field is not required if you are writing a Client since the server will put the JID of your connection in there to prevent spamming. $Mess->SetFrom("me\@jabber.org"); SetType(string) - sets the type attribute. Valid settings are: normal regular message (default if blank) chat one one one chat style message groupchat multi-person chatroom message headline news headline, stock ticker, etc... error error message $Mess->SetType("groupchat"); SetSubject(string) - sets the subject of the . $Mess->SetSubject("This is a test"); SetBody(string) - sets the body of the . $Mess->SetBody("To be or not to be..."); SetThread(string) - sets the thread of the . You should copy this out of the message being replied to so that the thread is maintained. $Mess->SetThread("AE912B3"); SetErrorCode(string) - sets the error code of the . $Mess->SetErrorCode(403); SetError(string) - sets the error string of the . $Mess->SetError("Permission Denied"); Reply(hash) - creates a new Message object and populates the to/from, and the subject by putting "re: " in front. If you specify a hash the same as with SetMessage then those values will override the Reply values. $Reply = $Mess->Reply(); $Reply = $Mess->Reply(type=>"chat"); =head2 Removal functions RemoveTo() - removes the to attribute from the . $Mess->RemoveTo(); RemoveFrom() - removes the from attribute from the . $Mess->RemoveFrom(); RemoveType() - removes the type attribute from the . $Mess->RemoveType(); RemoveSubject() - removes the element from the . $Mess->RemoveSubject(); RemoveBody() - removes the element from the . $Mess->RemoveBody(); RemoveThread() - removes the element from the . $Mess->RemoveThread(); RemoveError() - removes the element from the . $Mess->RemoveError(); RemoveErrorCode() - removes the code attribute from the element in the . $Mess->RemoveErrorCode(); =head2 Test functions DefinedTo() - returns 1 if the to attribute is defined in the , 0 otherwise. $test = $Mess->DefinedTo(); DefinedFrom() - returns 1 if the from attribute is defined in the , 0 otherwise. $test = $Mess->DefinedFrom(); DefinedType() - returns 1 if the type attribute is defined in the , 0 otherwise. $test = $Mess->DefinedType(); DefinedSubject() - returns 1 if is defined in the , 0 otherwise. $test = $Mess->DefinedSubject(); DefinedBody() - returns 1 if is defined in the , 0 otherwise. $test = $Mess->DefinedBody(); DefinedThread() - returns 1 if is defined in the , 0 otherwise. $test = $Mess->DefinedThread(); DefinedErrorCode() - returns 1 if is defined in the , 0 otherwise. $test = $Mess->DefinedErrorCode(); DefinedError() - returns 1 if the code attribute is defined in the , 0 otherwise. $test = $Mess->DefinedError(); =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut require 5.003; use strict; use Carp; use vars qw( %FUNCTIONS ); use Net::XMPP::Stanza; use base qw( Net::XMPP::Stanza ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; bless($self, $proto); $self->{DEBUGHEADER} = "Message"; $self->{TAG} = "message"; $self->{TIMESTAMP} = &Net::XMPP::GetTimeStamp("local"); $self->{FUNCS} = \%FUNCTIONS; $self->_init(@_); return $self; } sub _message { my $self = shift; return new Net::XMPP::Message(); } # Copied from Net::Jabber::Message because GetTimeStamp doesn't work without DefinedX sub GetX { my $self = shift; $self->GetChild(@_); } sub DefinedX { my $self = shift; $self->DefinedChild(@_); } sub NewX { my $self = shift; $self->NewChild(@_); } sub AddX { my $self = shift; $self->AddChild(@_); } sub RemoveX { my $self = shift; $self->RemoveChild(@_); } $FUNCTIONS{Body}->{path} = 'body/text()'; $FUNCTIONS{Error}->{path} = 'error/text()'; $FUNCTIONS{ErrorCode}->{path} = 'error/@code'; $FUNCTIONS{From}->{type} = 'jid'; $FUNCTIONS{From}->{path} = '@from'; $FUNCTIONS{ID}->{path} = '@id'; $FUNCTIONS{Subject}->{path} = 'subject/text()'; $FUNCTIONS{Thread}->{path} = 'thread/text()'; $FUNCTIONS{To}->{type} = 'jid'; $FUNCTIONS{To}->{path} = '@to'; $FUNCTIONS{Type}->{path} = '@type'; $FUNCTIONS{XMLNS}->{path} = '@xmlns'; $FUNCTIONS{Message}->{type} = 'master'; $FUNCTIONS{Child}->{type} = 'child'; $FUNCTIONS{Child}->{path} = '*[@xmlns]'; $FUNCTIONS{Child}->{child} = {}; ############################################################################## # # GetTimeStamp - returns a string with the time stamp of when this object # was created. # ############################################################################## sub GetTimeStamp { my $self = shift; if ($self->DefinedX("jabber:x:delay")) { my @xTags = $self->GetX("jabber:x:delay"); my $xTag = $xTags[0]; $self->{TIMESTAMP} = &Net::XMPP::GetTimeStamp("utcdelaylocal",$xTag->GetStamp()); } return $self->{TIMESTAMP}; } ############################################################################## # # Reply - returns a Net::XMPP::Message object with the proper fields # already populated for you. # ############################################################################## sub Reply { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $reply = $self->_message(); if (($self->GetType() eq "") || ($self->GetType() eq "normal")) { my $subject = $self->GetSubject(); $subject =~ s/re\:\s+//i; $reply->SetSubject("re: $subject"); } $reply->SetThread($self->GetThread()) if ($self->GetThread() ne ""); $reply->SetID($self->GetID()) if ($self->GetID() ne ""); $reply->SetType($self->GetType()) if ($self->GetType() ne ""); $reply->SetMessage((($self->GetFrom() ne "") ? (to=>$self->GetFrom()) : () ), (($self->GetTo() ne "") ? (from=>$self->GetTo()) : () ), ); $reply->SetMessage(%args); return $reply; } 1; Namespaces.pm000444000000000000 5757410602727703 20114 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::Namespaces; =head1 NAME Net::XMPP::Namespaces - In depth discussion on how namespaces are handled =head1 SYNOPSIS Net::XMPP::Namespaces provides an depth look at how Net::XMPP handles namespacs, and how to add your own custom ones. It also serves as the storage bin for all of the Namespace information Net::XMPP requires. =head1 DESCRIPTION XMPP as a protocol is very well defined. There are three main top level packets (message, iq, and presence). There is also a way to extend the protocol in a very clear and strucutred way, via namespaces. Two major ways that namespaces are used in Jabber is for making the a generic wrapper, and as a way for adding data to any packet via a child tag . We will use to represent the packet, but in reality it could be any child tag: , , , etc. The Info/Query packet uses namespaces to determine the type of information to access. Usually there is a tag in the that represents the namespace, but in fact it can be any tag. The definition of the Query portion, is the first tag that has a namespace. or After that Query stanza can be any number of other stanzas ( tags) you want to include. The Query packet is represented and available by calling GetQuery() or GetChild(), and the other namespaces are available by calling GetChild(). The X tag is just a way to piggy back data on other packets. Like embedding the timestamp for a message using jabber:x:delay, or signing you presence for encryption using jabber:x:signed. To this end, Net::XMPP has sought to find a way to easily, and clearly define the functions needed to access the XML for a namespace. We will go over the full docs, and then show two examples of real namespaces so that you can see what we are talking about. =head2 Overview To avoid a lot of nasty modules populating memory that are not used, and to avoid having to change 15 modules when a minor change is introduced, the Net::XMPP modules have taken AUTOLOADing to the extreme. Namespaces.pm is nothing but a set of function calls that generates a big hash of hashes. The hash is accessed by the Stanza.pm AUTOLOAD function to do something. (This will make sense, I promise.) Before going on, I highly suggest you read a Perl book on AUTOLOAD and how it works. From this point on I will assume that you understand it. When you create a Net::XMPP::IQ object and add a Query to it (NewChild) several things are happening in the background. The argument to NewChild is the namespace you want to add. (custom-namespace) Now that you have a Query object to work with you will call the GetXXX functions, and SetXXX functions to set the data. There are no defined GetXXX and SetXXXX functions. You cannot look in the Namespaces.pm file and find them. Instead you will find something like this: &add_ns(ns => "mynamespace", tag => "mytag", xpath => { JID => { type=>'jid', path => '@jid' }, Username => { path => 'username/text()' }, Test => { type => 'master' } } ); When the GetUsername() function is called, the AUTOLOAD function looks in the Namespaces.pm hash for a "Username" key. Based on the "type" of the field (scalar being the default) it will use the "path" as an XPath to retrieve the data and call the XPathGet() method in Stanza.pm. Confused yet? =head2 Net::XMPP private namespaces Now this is where this starts to get a little sticky. When you see a namespace with __netxmpp__, or __netjabber__ from Net::Jabber, at the beginning it is usually something custom to Net::XMPP and NOT part of the actual XMPP protocol. There are some places where the structure of the XML allows for multiple children with the same name. The main places you will see this behavior is where you have multiple tags with the same name and those have children under them (jabber:iq:roster). In jabber:iq:roster, the tag can be repeated multiple times, and is sort of like a mini-namespace in itself. To that end, we treat it like a seperate namespace and defined a __netxmpp__:iq:roster:item namespace to hold it. What happens is this, in my code I define that the s tag is "item" and anything with that tag name is to create a new Net::XMPP::Stanza object with the namespace __netxmpp__:iq:roster:item which then becomes a child of the jabber:iq:roster Stanza object. Also, when you want to add a new item to a jabber:iq:roster project you call NewQuery with the private namespace. I know this sounds complicated. And if after reading this entire document it is still complicated, email me, ask questions, and I will monitor it and adjust these docs to answer the questions that people ask. =head2 add_ns() To repeat, here is an example call to add_ns(): &add_ns(ns => "mynamespace", tag => "mytag", xpath => { JID => { type=>'jid', path => '@jid' }, Username => { path => 'username/text()' }, Test => { type => 'master' } } ); ns - This is the new namespace that you are trying to add. tag - This is the root tag to use for objects based on this namespace. xpath - The hash reference passed in the add_ns call to each name of entry tells Net::XMPP how to handle subsequent GetXXXX(), SetXXXX(), DefinedXXXX(), RemoveXXXX(), AddXXXX() calls. The basic options you can pass in are: type - This tells Stanza how to handle the call. The possible values are: array - The value to set and returned is an an array reference. For example, in jabber:iq:roster. child - This tells Stanza that it needs to look for the __netxmpp__ style namesapced children. AddXXX() adds a new child, and GetXXX() will return a new Stanza object representing the packet. flag - This is for child elements that are tags by themselves: . Since the presence of the tag is what is important, and there is no cdata to store, we just call it a flag. jid - The value is a Jabber ID. GetXXX() will return a Net::XMPP::JID object unless you pass it "jid", then it returns a string. master - The GetXXX() and SetXXX() calls return and take a hash representing all of the GetXXX() and SetXXX() calls. For example: SetTest(foo=>"bar", bar=>"baz"); Translates into: SetFoo("bar"); SetBar("baz"); GetTest() would return a hash containing what the packet contains: { foo=>"bar", bar=>"baz" } raw - This will stick whatever raw XML you specify directly into the Stanza at the point where the path specifies. scalar - This will set and get a scalar value. This is the main workhorse as attributes and CDATA is represented by a scalar. This is the default setting if you do not provide one. special - The special type is unique in that instead of a string "special", you actually give it an array: [ "special" , ] This allows Net::XMPP to be able to handle the SetXXXX() call in a special manner according to your choosing. Right now this is mainly used by jabber:iq:time to automatically set the time info in the correct format, and jabber:iq:version to set the machine OS and add the Net::Jabber version to the return packet. You will likely NOT need to use this, but I wanted to mention it. timestamp - If you call SetXXX() but do not pass it anything, or pass it "", then Net::XMPP will place a timestamp in the xpath location. path - This is the XPath path to where the bit data lives. The difference. Now, this is not full XPath due to the nature of how it gets used. Instead of providing a rooted path all the way to the top, it's a relative path ignoring what the parent is. For example, if the "tag" you specified was "foo", and the path is "bar/text()", then the XPath will be rooted in the XML of the packet. It will set and get the CDATA from: xxxxx For a flag and a child type, just specify the child element. Take a look at the code in this file for more help on what this means. Also, read up on XPath if you don't already know what it is. child - This is a hash reference that tells Net::XMPP how to handle adding and getting child objects. The keys for the hash are as follows: ns - the real or custom (__netxmpp__) namesapce to use for this child packet. skip_xmlns => 1 - this tells Net::XMPP not to add an xmlns='' into the XML for the child object. specify_name => 1 - allows you to call NewChild("ns","tag") and specify the tag to use for the child object. This, IMHO, is BAD XML practice. You should always know what the tag of the child is and use an attribute or CDATA to change the type of the stanza. You do not want to use this. tag - If you use specify_name, then this is the default tag to use. You do not want to use this. calls - Array reference telling Net::XMPP what functions to create for this name. For most of the types above you will get Get, Set, Defined, and Remove. For child types you need to decide how you API will look and specify them yourself: ["Get","Defined"] ["Add"] ["Get","Add","Defined"] It all depends on how you want your API to look. Once more... The following: &add_ns(ns => "mynamespace", tag => "mytag", xpath => { JID => { type=>'jid', path => '@jid' }, Username => { path => 'username/text()' }, Test => { type => 'master' } } ); generates the following API calls: GetJID() SetJID() DefinedJID() RemoveJID() GetUsername() SetUsername() DefinedUsername() RemoveUsername() GetTest() SetTest() =head2 Wrap Up Well. I hope that I have not scared you off from writing a custom namespace for you application and use Net::XMPP. Look in the Net::XMPP::Protocol manpage for an example on using the add_ns() function to register your custom namespace so that Net::XMPP can properly handle it. =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut use vars qw ( %NS %SKIPNS ); $SKIPNS{'__netxmpp__'} = 1; #------------------------------------------------------------------------------ # __netxmpp__:child:test #------------------------------------------------------------------------------ { &add_ns(ns => "__netxmpptest__:child:test", tag => "test", xpath => { Bar => { path => 'bar/text()' }, Foo => { path => '@foo' }, Test => { type => 'master' } } ); } #------------------------------------------------------------------------------ # __netxmpp__:child:test:two #------------------------------------------------------------------------------ { &add_ns(ns => "__netxmpptest__:child:test:two", tag => "test", xpath => { Bob => { path => 'owner/@bob' }, Joe => { path => 'joe/text()' }, Test => { type => 'master' } } ); } #----------------------------------------------------------------------------- # urn:ietf:params:xml:ns:xmpp-bind #----------------------------------------------------------------------------- { &add_ns(ns => "urn:ietf:params:xml:ns:xmpp-bind", tag => "bind", xpath => { JID => { type => 'jid', path => 'jid/text()', }, Resource => { path => 'resource/text()' }, Bind => { type => 'master' }, }, docs => { module => 'Net::XMPP', }, ); } #----------------------------------------------------------------------------- # urn:ietf:params:xml:ns:xmpp-session #----------------------------------------------------------------------------- { &add_ns(ns => "urn:ietf:params:xml:ns:xmpp-session", tag => "session", xpath => { Session => { type => 'master' } }, docs => { module => 'Net::XMPP', }, ); } #----------------------------------------------------------------------------- # jabber:iq:auth #----------------------------------------------------------------------------- { &add_ns(ns => "jabber:iq:auth", tag => "query", xpath => { Digest => { path => 'digest/text()' }, Hash => { path => 'hash/text()' }, Password => { path => 'password/text()' }, Resource => { path => 'resource/text()' }, Sequence => { path => 'sequence/text()' }, Token => { path => 'token/text()' }, Username => { path => 'username/text()' }, Auth => { type => 'master' }, }, docs => { module => 'Net::XMPP', }, ); } #----------------------------------------------------------------------------- # jabber:iq:privacy #----------------------------------------------------------------------------- { &add_ns(ns => "jabber:iq:privacy", tag => "query", xpath => { Active => { path => 'active/@name' }, Default => { path => 'default/@name' }, List => { type => 'child', path => 'list', child => { ns => '__netxmpp__:iq:privacy:list', }, calls => [ 'Add' ], }, Lists => { type => 'child', path => 'list', child => { ns => '__netxmpp__:iq:privacy:list', }, }, Privacy => { type => 'master' }, }, docs => { module => 'Net::XMPP', }, ); } #----------------------------------------------------------------------------- # __netxmpp__:iq:privacy:list #----------------------------------------------------------------------------- { &add_ns(ns => '__netxmpp__:iq:privacy:list', xpath => { Name => { path => '@name' }, Item => { type => 'child', path => 'item', child => { ns => '__netxmpp__:iq:privacy:list:item', }, calls => [ 'Add' ], }, Items => { type => 'child', path => 'item', child => { ns => '__netxmpp__:iq:privacy:item', }, }, List => { type => 'master' }, }, docs => { module => 'Net::XMPP', name => 'jabber:iq:privacy - list objects', }, ); } #----------------------------------------------------------------------------- # __netxmpp__:iq:privacy:list:item #----------------------------------------------------------------------------- { &add_ns(ns => '__netxmpp__:iq:privacy:list:item', xpath => { Action => { path => '@action' }, IQ => { type => 'flag', path => 'iq', }, Message => { type => 'flag', path => 'message', }, Order => { path => '@order' }, PresenceIn => { type => 'flag', path => 'presence-in', }, PresenceOut => { type => 'flag', path => 'presence-out', }, Type => { path => '@type' }, Value => { path => '@value' }, Item => { type => 'master' }, }, docs => { module => 'Net::XMPP', name => 'jabber:iq:privacy - item objects', }, ); } #----------------------------------------------------------------------------- # jabber:iq:register #----------------------------------------------------------------------------- { &add_ns(ns => "jabber:iq:register", tag => "query", xpath => { Address => { path => 'address/text()' }, City => { path => 'city/text()' }, Date => { path => 'date/text()' }, Email => { path => 'email/text()' }, First => { path => 'first/text()' }, Instructions => { path => 'instructions/text()' }, Key => { path => 'key/text()' }, Last => { path => 'last/text()' }, Misc => { path => 'misc/text()' }, Name => { path => 'name/text()' }, Nick => { path => 'nick/text()' }, Password => { path => 'password/text()' }, Phone => { path => 'phone/text()' }, Registered => { type => 'flag', path => 'registered', }, Remove => { type => 'flag', path => 'remove', }, State => { path => 'state/text()' }, Text => { path => 'text/text()' }, URL => { path => 'url/text()' }, Username => { path => 'username/text()' }, Zip => { path => 'zip/text()' }, Register => { type => 'master' }, }, docs => { module => 'Net::XMPP', }, ); } #----------------------------------------------------------------------------- # jabber:iq:roster #----------------------------------------------------------------------------- { &add_ns(ns => 'jabber:iq:roster', tag => "query", xpath => { Item => { type => 'child', path => 'item', child => { ns => '__netxmpp__:iq:roster:item', }, calls => [ 'Add' ], }, Items => { type => 'child', path => 'item', child => { ns => '__netxmpp__:iq:roster:item', }, calls => [ 'Get' ], }, Roster => { type => 'master' }, }, docs => { module => 'Net::XMPP', }, ); } #----------------------------------------------------------------------------- # __netxmpp__:iq:roster:item #----------------------------------------------------------------------------- { &add_ns(ns => "__netxmpp__:iq:roster:item", xpath => { Ask => { path => '@ask' }, Group => { type => 'array', path => 'group/text()', }, JID => { type => 'jid', path => '@jid', }, Name => { path => '@name' }, Subscription => { path => '@subscription' }, Item => { type => 'master' }, }, docs => { module => 'Net::XMPP', name => 'jabber:iq:roster - item objects', }, ); } sub add_ns { my (%args) = @_; # XXX error check... $NS{$args{ns}}->{tag} = $args{tag} if exists($args{tag}); $NS{$args{ns}}->{xpath} = $args{xpath}; if (exists($args{docs})) { $NS{$args{ns}}->{docs} = $args{docs}; $NS{$args{ns}}->{docs}->{name} = $args{ns} unless exists($args{docs}->{name}); } } 1; Presence.pm000444000000000000 2467310602727725 17577 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################# # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::Presence; =head1 NAME Net::XMPP::Presence - XMPP Presence Module =head1 SYNOPSIS Net::XMPP::Presence is a companion to the Net::XMPP module. It provides the user a simple interface to set and retrieve all parts of an XMPP Presence. =head1 DESCRIPTION A Net::XMPP::Presence object is passed to the callback function for the message. Also, the first argument to the callback functions is the session ID from XML::Streams. There are some cases where you might want this information, like if you created a Client that connects to two servers at once, or for writing a mini server. use Net::XMPP; sub presence { my ($sid,$Pres) = @_; . . . } You now have access to all of the retrieval functions available. To create a new presence to send to the server: use Net::XMPP; $Pres = new Net::XMPP::Presence(); Now you can call the creation functions below to populate the tag before sending it. =head1 METHODS =head2 Retrieval functions GetTo() - returns the value in the to='' attribute for the GetTo("jid") . If you specify "jid" as an argument then a Net::XMPP::JID object is returned and you can easily parse the parts of the JID. $to = $Pres->GetTo(); $toJID = $Pres->GetTo("jid"); GetFrom() - returns the value in the from='' attribute for the GetFrom("jid") . If you specify "jid" as an argument then a Net::XMPP::JID object is returned and you can easily parse the parts of the JID. $from = $Pres->GetFrom(); $fromJID = $Pres->GetFrom("jid"); GetType() - returns the type='' attribute of the . Each presence is one of seven types: available available to receive messages; default unavailable unavailable to receive anything subscribe ask the recipient to subscribe you subscribed tell the sender they are subscribed unsubscribe ask the recipient to unsubscribe you unsubscribed tell the sender they are unsubscribed probe probe $type = $Pres->GetType(); GetStatus() - returns a string with the current status of the resource. $status = $Pres->GetStatus(); GetPriority() - returns an integer with the priority of the resource The default is 0 if there is no priority in this presence. $priority = $Pres->GetPriority(); GetShow() - returns a string with the state the client should show. $show = $Pres->GetShow(); =head2 Creation functions SetPresence(to=>string|JID - set multiple fields in the from=>string|JID, at one time. This is a cumulative type=>string, and over writing action. If you set status=>string, the "to" attribute twice, the second priority=>integer, setting is what is used. If you set meta=>string, the status, and then set the priority icon=>string, then both will be in the show=>string, tag. For valid settings read the loc=>string) specific Set functions below. $Pres->SetPresence(TYPE=>"away", StatuS=>"Out for lunch"); SetTo(string) - sets the to attribute. You can either pass a string SetTo(JID) or a JID object. They must be valid JIDs or the server will return an error message. (ie. bob@jabber.org/Silent Bob, etc...) $Pres->SetTo("bob\@jabber.org"); SetFrom(string) - sets the from='' attribute. You can either pass SetFrom(JID) a string or a JID object. They must be valid JIDs or the server will return an error message. (ie. jabber:bob@jabber.org/Work) This field is not required if you are writing a Client since the server will put the JID of your connection in there to prevent spamming. $Pres->SetFrom("jojo\@jabber.org"); SetType(string) - sets the type attribute. Valid settings are: available available to receive messages; default unavailable unavailable to receive anything subscribe ask the recipient to subscribe you subscribed tell the sender they are subscribed unsubscribe ask the recipient to unsubscribe you unsubscribed tell the sender they are unsubscribed probe probe $Pres->SetType("unavailable"); SetStatus(string) - sets the status tag to be whatever string the user wants associated with that resource. $Pres->SetStatus("Taking a nap"); SetPriority(integer) - sets the priority of this resource. The highest resource attached to the xmpp account is the one that receives the messages. $Pres->SetPriority(10); SetShow(string) - sets the name of the icon or string to display for this resource. $Pres->SetShow("away"); Reply(hash) - creates a new Presence object and populates the to/from fields. If you specify a hash the same as with SetPresence then those values will override the Reply values. $Reply = $Pres->Reply(); $Reply = $Pres->Reply(type=>"subscribed"); =head2 Removal functions RemoveTo() - removes the to attribute from the . $Pres->RemoveTo(); RemoveFrom() - removes the from attribute from the . $Pres->RemoveFrom(); RemoveType() - removes the type attribute from the . $Pres->RemoveType(); RemoveStatus() - removes the element from the . $Pres->RemoveStatus(); RemovePriority() - removes the element from the . $Pres->RemovePriority(); RemoveShow() - removes the element from the . $Pres->RemoveShow(); =head2 Test functions DefinedTo() - returns 1 if the to attribute is defined in the , 0 otherwise. $test = $Pres->DefinedTo(); DefinedFrom() - returns 1 if the from attribute is defined in the , 0 otherwise. $test = $Pres->DefinedFrom(); DefinedType() - returns 1 if the type attribute is defined in the , 0 otherwise. $test = $Pres->DefinedType(); DefinedStatus() - returns 1 if is defined in the , 0 otherwise. $test = $Pres->DefinedStatus(); DefinedPriority() - returns 1 if is defined in the , 0 otherwise. $test = $Pres->DefinedPriority(); DefinedShow() - returns 1 if is defined in the , 0 otherwise. $test = $Pres->DefinedShow(); =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut require 5.003; use strict; use Carp; use vars qw( %FUNCTIONS ); use Net::XMPP::Stanza; use base qw( Net::XMPP::Stanza ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { }; bless($self, $proto); $self->{DEBUGHEADER} = "Presence"; $self->{TAG} = "presence"; $self->{FUNCS} = \%FUNCTIONS; $self->_init(@_); return $self; } sub _presence { my $self = shift; return new Net::XMPP::Presence(); } $FUNCTIONS{Error}->{path} = 'error/text()'; $FUNCTIONS{ErrorCode}->{path} = 'error/@code'; $FUNCTIONS{From}->{type} = 'jid'; $FUNCTIONS{From}->{path} = '@from'; $FUNCTIONS{ID}->{path} = '@id'; $FUNCTIONS{Priority}->{path} = 'priority/text()'; $FUNCTIONS{Show}->{path} = 'show/text()'; $FUNCTIONS{Status}->{path} = 'status/text()'; $FUNCTIONS{To}->{type} = 'jid'; $FUNCTIONS{To}->{path} = '@to'; $FUNCTIONS{Type}->{path} = '@type'; $FUNCTIONS{XMLNS}->{path} = '@xmlns'; $FUNCTIONS{Presence}->{type} = 'master'; $FUNCTIONS{Child}->{type} = 'child'; $FUNCTIONS{Child}->{path} = '*[@xmlns]'; $FUNCTIONS{Child}->{child} = {}; ############################################################################## # # Reply - returns a Net::XMPP::Presence object with the proper fields # already populated for you. # ############################################################################## sub Reply { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $reply = $self->_presence(); $reply->SetID($self->GetID()) if ($self->GetID() ne ""); $reply->SetPresence((($self->GetFrom() ne "") ? (to=>$self->GetFrom()) : () ), (($self->GetTo() ne "") ? (from=>$self->GetTo()) : () ), ); $reply->SetPresence(%args); return $reply; } 1; PrivacyLists.pm000444000000000000 2004210602727744 20452 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::PrivacyLists; =head1 NAME Net::XMPP::PrivacyLists - XMPP Privacy Lists Object =head1 SYNOPSIS This module is not yet complete. Do not use. =head1 DESCRIPTION =head2 Basic Functions =head2 Advanced Functions =head1 METHODS =head2 Basic Functions =head2 Advanced Functions =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut use strict; use Carp; sub new { my $proto = shift; my $self = { }; my %args; while($#_ >= 0) { $args{ lc(pop(@_)) } = pop(@_); } $self->{CONNECTION} = $args{connection}; bless($self, $proto); $self->init(); return $self; } ############################################################################## # # init - initialize the module to use the privacy lists. # ############################################################################## sub init { my $self = shift; $self->{CONNECTION}-> SetXPathCallBacks('/iq[@type="result" or @type="set"]/query[@xmlns="jabber:iq:privacy"]'=>sub{ $self->handler(@_) }); } ############################################################################## # # debug - print out a representation of the privacy lists. # ############################################################################## sub debug { my $self = shift; &XML::Stream::printData("\$self->{LISTS}",$self->{LISTS}); } ############################################################################## # # addItem - add list item to a list. # ############################################################################## sub addItem { my $self = shift; my ($list,%item) = @_; my $order = delete($item{order}); $self->{LISTS}->{$list}->{$order} = \%item; } ############################################################################### # # clear - delete all of the JIDs from the DB completely. # ############################################################################### sub clear { my $self = shift; $self->{CONNECTION}->{DEBUG}->Log3("PrivacyLists::clear: clearing the database"); foreach my $list ($self->lists()) { $self->remove($list); } $self->{CONNECTION}->{DEBUG}->Log3("PrivacyLists::clear: database is empty"); } ############################################################################## # # exists - allows you to query if the JID exists in the Roster DB. # ############################################################################## sub exists { my $self = shift; my $list = shift; return unless exists($self->{LISTS}); return unless exists($self->{LISTS}->{$list}); return 1; } ############################################################################## # # fetch - fetch the privacy lists from the server and populate the database. # ############################################################################## sub fetch { my $self = shift; my $iq = $self->{CONNECTION}->PrivacyListsGet(); $self->handleIQ($iq); } ############################################################################## # # fetchList - fetch the privacy list from the server and populate the database. # ############################################################################## sub fetchList { my $self = shift; my $list = shift; my $iq = $self->{CONNECTION}->PrivacyListsGet(list=>$list); $self->handleIQ($iq); } ############################################################################## # # lists - returns a list of the current privacy lists. # ############################################################################## sub lists { my $self = shift; return () unless exists($self->{LISTS}); return () if (scalar(keys(%{$self->{LISTS}})) == 0); return keys(%{$self->{LISTS}}); } ############################################################################## # # items - returns a list of all of the items in the specified privacy list. # ############################################################################## sub items { my $self = shift; my $list = shift; my @items; return () unless $self->exists($list); foreach my $order (sort{ $a <=> $b } keys(%{$self->{LISTS}->{$list}})) { my %item = %{$self->{LISTS}->{$list}->{$order}}; $item{order} = $order; push(@items,\%item); } return @items; } ############################################################################## # # handler - takes a packet and calls the correct handler. # ############################################################################## sub handler { my $self = shift; my $sid = shift; my $packet = shift; $self->handleIQ($packet) if ($packet->GetTag() eq "iq"); } ############################################################################## # # handleIQ - takes an iq packet that contains roster, parses it, and puts # the roster into the Roster DB. # ############################################################################## sub handleIQ { my $self = shift; my $iq = shift; print "handleIQ: iq(",$iq->GetXML(),")\n"; my $type = $iq->GetType(); return unless (($type eq "set") || ($type eq "result")); if ($type eq "result") { my $query = $iq->GetChild("jabber:iq:privacy"); my @lists = $query->GetLists(); return unless ($#lists > -1); my @items = $lists[0]->GetItems(); if (($#lists == 0) && ($#items > -1)) { $self->parseList($lists[0]); } elsif ($#lists >= -1) { $self->parseLists(\@lists); } } } sub parseList { my $self = shift; my $list = shift; my $name = $list->GetName(); foreach my $item ($list->GetItems()) { my %item = $item->GetItem(); $self->addItem($name,%item); } } sub parseLists { my $self = shift; my $lists = shift; foreach my $list (@{$lists}) { my $name = $list->GetName(); $self->fetchList($name); } } ############################################################################## # # reload - clear and refetch the privacy lists. # ############################################################################## sub reload { my $self = shift; $self->clear(); $self->fetch(); } ############################################################################## # # remove - removes the list from the database. # ############################################################################## sub remove { my $self = shift; my $list = shift; if ($self->exists($list)) { $self->{CONNECTION}->{DEBUG}->Log3("PrivacyLists::remove: deleting $list from the DB"); delete($self->{LISTS}->{$list}); delete($self->{LISTS}) if (scalar(keys(%{$self->{LISTS}})) == 0); } } sub save { my $self = shift; foreach my $list ($self->lists()) { $self->saveList($list); } } sub saveList { my $self = shift; my $list = shift; my @items = $self->items($list); $self->{CONNECTION}->PrivacyListsSet(list=>$list, items=>\@items); } 1; Protocol.pm000444000000000000 33625710602730003 17637 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::Protocol; =head1 NAME Net::XMPP::Protocol - XMPP Protocol Module =head1 SYNOPSIS Net::XMPP::Protocol is a module that provides a developer easy access to the XMPP Instant Messaging protocol. It provides high level functions to the Net::XMPP Client object. These functions are inherited by that modules. =head1 DESCRIPTION Protocol.pm seeks to provide enough high level APIs and automation of the low level APIs that writing a XMPP Client in Perl is trivial. For those that wish to work with the low level you can do that too, but those functions are covered in the documentation for each module. Net::XMPP::Protocol provides functions to login, send and receive messages, set personal information, create a new user account, manage the roster, and disconnect. You can use all or none of the functions, there is no requirement. For more information on how the details for how Net::XMPP is written please see the help for Net::XMPP itself. For more information on writing a Client see Net::XMPP::Client. =head2 Modes Several of the functions take a mode argument that let you specify how the function should behave: block - send the packet with an ID, and then block until an answer comes back. You can optionally specify a timeout so that you do not block forever. nonblock - send the packet with an ID, but then return that id and control to the master program. Net::XMPP is still tracking this packet, so you must use the CheckID function to tell when it comes in. (This might not be very useful...) passthru - send the packet with an ID, but do NOT register it with Net::XMPP, then return the ID. This is useful when combined with the XPath function because you can register a one shot function tied to the id you get back. =head2 Basic Functions use Net::XMPP qw( Client ); $Con = new Net::XMPP::Client(); # From $status = $Con->Connect(hostname=>"jabber.org"); # Net::XMPP::Client $Con->SetCallBacks(send=>\&sendCallBack, receive=>\&receiveCallBack, message=>\&messageCallBack, iq=>\&handleTheIQTag); $Con->SetMessageCallBacks(normal=>\&messageNormalCB, chat=>\&messageChatCB); $Con->SetPresenceCallBacks(available=>\&presenceAvailableCB, unavailable=>\&presenceUnavailableCB); $Con->SetIQCallBacks("custom-namespace"=> { get=>\&iqCustomGetCB, set=>\&iqCustomSetCB, result=>\&iqCustomResultCB, }, etc... ); $Con->SetXPathCallBacks("/message[@type='chat']"=>&messageChatCB, "/message[@type='chat']"=>&otherMessageChatCB, ... ); $Con->RemoveXPathCallBacks("/message[@type='chat']"=>&otherMessageChatCB); $Con->SetDirectXPathCallBacks("/anything"=>&anythingCB, "/anotherthing[@foo='bar']"=>&anotherthingFooBarCB, ... ); $Con->RemoveDirectXPathCallBacks("/message[@type='chat']"=>&otherMessageChatCB); $error = $Con->GetErrorCode(); $Con->SetErrorCode("Timeout limit reached"); $status = $Con->Process(); $status = $Con->Process(5); $Con->Send($object); $Con->Send("XML"); $Con->Send($object,1); $Con->Send("XML",1); $Con->Disconnect(); =head2 ID Functions $id = $Con->SendWithID($sendObj); $id = $Con->SendWithID("XML"); $receiveObj = $Con->SendAndReceiveWithID($sendObj); $receiveObj = $Con->SendAndReceiveWithID($sendObj, 10); $receiveObj = $Con->SendAndReceiveWithID("XML"); $receiveObj = $Con->SendAndReceiveWithID("XML", 5); $yesno = $Con->ReceivedID($id); $receiveObj = $Con->GetID($id); $receiveObj = $Con->WaitForID($id); $receiveObj = $Con->WaitForID($id, 20); =head2 Namespace Functions $Con->AddNamespace(ns=>"foo:bar", tag=>"myfoo", xpath=>{Foo=>{ path=> "foo/text()" }, Bar=>{ path=> "bar/text()" }, FooBar=>{ type=> "master" }, } ); =head2 Message Functions $Con->MessageSend(to=>"bob@jabber.org", subject=>"Lunch", body=>"Let's go grab some...\n", thread=>"ABC123", priority=>10); =head2 Presence Functions $Con->PresenceSend(); $Con->PresenceSend(type=>"unavailable"); $Con->PresenceSend(show=>"away"); $Con->PresenceSend(signature=>...signature...); =head2 Subscription Functions $Con->Subscription(type=>"subscribe", to=>"bob@jabber.org"); $Con->Subscription(type=>"unsubscribe", to=>"bob@jabber.org"); $Con->Subscription(type=>"subscribed", to=>"bob@jabber.org"); $Con->Subscription(type=>"unsubscribed", to=>"bob@jabber.org"); =head2 Presence DB Functions $Con->PresenceDB(); $Con->PresenceDBParse(Net::XMPP::Presence); $Con->PresenceDBDelete("bob\@jabber.org"); $Con->PresenceDBDelete(Net::XMPP::JID); $Con->PresenceDBClear(); $presence = $Con->PresenceDBQuery("bob\@jabber.org"); $presence = $Con->PresenceDBQuery(Net::XMPP::JID); @resources = $Con->PresenceDBResources("bob\@jabber.org"); @resources = $Con->PresenceDBResources(Net::XMPP::JID); =head2 IQ Functions =head2 Auth Functions @result = $Con->AuthSend(); @result = $Con->AuthSend(username=>"bob", password=>"bobrulez", resource=>"Bob"); =head2 Register Functions %hash = $Con->RegisterRequest(); %hash = $Con->RegisterRequest(to=>"transport.jabber.org"); %hash = $Con->RegisterRequest(to=>"transport.jabber.org", timeout=>10); @result = $Con->RegisterSend(to=>"somewhere", username=>"newuser", resource=>"New User", password=>"imanewbie", email=>"newguy@new.com", key=>"some key"); =head2 Roster Functions $Roster = $Con->Roster(); %roster = $Con->RosterParse($iq); %roster = $Con->RosterGet(); $Con->RosterRequest(); $Con->RosterAdd(jid=>"bob\@jabber.org", name=>"Bob"); $Con->RosterRemove(jid=>"bob@jabber.org"); =head2 Roster DB Functions $Con->RosterDB(); $Con->RosterDBParse(Net::XMPP::IQ); $Con->RosterDBAdd("bob\@jabber.org", name=>"Bob", groups=>["foo"] ); $Con->RosterDBRemove("bob\@jabber.org"); $Con->RosterDBRemove(Net::XMPP::JID); $Con->RosterDBClear(); if ($Con->RosterDBExists("bob\@jabber.org")) { ... if ($Con->RosterDBExists(Net::XMPP::JID)) { ... @jids = $Con->RosterDBJIDs(); if ($Con->RosterDBGroupExists("foo")) { ... @groups = $Con->RosterDBGroups(); @jids = $Con->RosterDBGroupJIDs("foo"); @jids = $Con->RosterDBNonGroupJIDs(); %hash = $Con->RosterDBQuery("bob\@jabber.org"); %hash = $Con->RosterDBQuery(Net::XMPP::JID); $value = $Con->RosterDBQuery("bob\@jabber.org","name"); $value = $Con->RosterDBQuery(Net::XMPP::JID,"groups"); =head1 METHODS =head2 Basic Functions GetErrorCode() - returns a string that will hopefully contain some useful information about why a function returned an undef to you. SetErrorCode(string) - set a useful error message before you return an undef to the caller. SetCallBacks(message=>function, - sets the callback functions for presence=>function, the top level tags listed. The iq=>function, available tags to look for are send=>function, , , and receive=>function, . If a packet is received update=>function) with an ID which is found in the registerd ID list (see RegisterID below) then it is not sent to these functions, instead it is inserted into a LIST and can be retrieved by some functions we will mention later. send and receive are used to log what XML is sent and received. update is used as way to update your program while waiting for a packet with an ID to be returned (useful for GUI apps). A major change that came with the last release is that the session id is passed to the callback as the first argument. This was done to facilitate the Server module. The next argument depends on which callback you are talking about. message, presence, and iq all get passed in Net::XMPP objects that match those types. send and receive get passed in strings. update gets passed nothing, not even the session id. If you set the function to undef, then the callback is removed from the list. SetPresenceCallBacks(type=>function - sets the callback functions for etc...) the specified presence type. The function takes types as the main key, and lets you specify a function for each type of packet you can get. "available" "unavailable" "subscribe" "unsubscribe" "subscribed" "unsubscribed" "probe" "error" When it gets a packet it checks the type='' for a defined callback. If there is one then it calls the function with two arguments: the session ID, and the Net::XMPP::Presence object. If you set the function to undef, then the callback is removed from the list. NOTE: If you use this, which is a cleaner method, then you must *NOT* specify a callback for presence in the SetCallBacks function. Net::XMPP defines a few default callbacks for various types: "subscribe" - replies with subscribed "unsubscribe" - replies with unsubscribed "subscribed" - replies with subscribed "unsubscribed" - replies with unsubscribed SetMessageCallBacks(type=>function, - sets the callback functions for etc...) the specified message type. The function takes types as the main key, and lets you specify a function for each type of packet you can get. "normal" "chat" "groupchat" "headline" "error" When it gets a packet it checks the type='' for a defined callback. If there is one then it calls the function with two arguments: the session ID, and the Net::XMPP::Message object. If you set the function to undef, then the callback is removed from the list. NOTE: If you use this, which is a cleaner method, then you must *NOT* specify a callback for message in the SetCallBacks function. SetIQCallBacks(namespace=>{ - sets the callback functions for get=>function, the specified namespace. The set=>function, function takes namespaces as the result=>function main key, and lets you specify a }, function for each type of packet etc...) you can get. "get" "set" "result" When it gets an packet it checks the type='' and the xmlns='' for a defined callback. If there is one then it calls the function with two arguments: the session ID, and the Net::XMPP::xxxx object. If you set the function to undef, then the callback is removed from the list. NOTE: If you use this, which is a cleaner method, then you must *NOT* specify a callback for iq in the SetCallBacks function. SetXPathCallBacks(xpath=>function, - registers a callback function etc...) for each xpath specified. If Net::XMPP matches the xpath, then it calls the function with two arguments: the session ID, and the Net::XMPP::Message object. Xpaths are rooted at each packet: /message[@type="chat"] /iq/*[xmlns="jabber:iq:roster"][1] ... RemoveXPathCallBacks(xpath=>function, - unregisters a callback etc...) function for each xpath specified. SetDirectXPathCallBacks(xpath=>function, - registers a callback function etc...) for each xpath specified. If Net::XMPP matches the xpath, then it calls the function with two arguments: the session ID, and the XML::Stream::Node object. Xpaths are rooted at each packet: /anything /anotherthing/foo/[1] ... The big difference between this and regular XPathCallBacks is the fact that this passes in the XML directly and not a Net::XMPP based object. RemoveDirectXPathCallBacks(xpath=>function, - unregisters a callback etc...) function for each xpath specified. Process(integer) - takes the timeout period as an argument. If no timeout is listed then the function blocks until a packet is received. Otherwise it waits that number of seconds and then exits so your program can continue doing useful things. NOTE: This is important for GUIs. You need to leave time to process GUI commands even if you are waiting for packets. The following are the possible return values, and what they mean: 1 - Status ok, data received. 0 - Status ok, no data received. undef - Status not ok, stop processing. IMPORTANT: You need to check the output of every Process. If you get an undef then the connection died and you should behave accordingly. Send(object, - takes either a Net::XMPP::xxxxx object or ignoreActivity) an XML string as an argument and sends it to Send(string, the server. If you set ignoreActivty to 1, ignoreActivity) then the XML::Stream module will not record this packet as couting towards user activity. =head2 ID Functions SendWithID(object) - takes either a Net::XMPP::xxxxx object or an SendWithID(string) XML string as an argument, adds the next available ID number and sends that packet to the server. Returns the ID number assigned. SendAndReceiveWithID(object, - uses SendWithID and WaitForID to timeout) provide a complete way to send and SendAndReceiveWithID(string, receive packets with IDs. Can take timeout) either a Net::XMPP::xxxxx object or an XML string. Returns the proper Net::XMPP::xxxxx object based on the type of packet received. The timeout is passed on to WaitForID, see that function for how the timeout works. ReceivedID(integer) - returns 1 if a packet has been received with specified ID, 0 otherwise. GetID(integer) - returns the proper Net::XMPP::xxxxx object based on the type of packet received with the specified ID. If the ID has been received the GetID returns 0. WaitForID(integer, - blocks until a packet with the ID is received. timeout) Returns the proper Net::XMPP::xxxxx object based on the type of packet received. If the timeout limit is reached then if the packet does come in, it will be discarded. NOTE: Only officially support ids, so sending a , or with an id is a risk. The server will ignore the id tag and pass it through, so both clients must support the id tag for these functions to be useful. =head2 Namespace Functions AddNamespace(ns=>string, - This function is very complex. tag=>string, It is a little too complex to xpath=>hash) discuss within the confines of this small paragraph. Please refer to the man page for Net::XMPP::Namespaces for the full documentation on this subject. =head2 Message Functions MessageSend(hash) - takes the hash and passes it to SetMessage in Net::XMPP::Message (refer there for valid settings). Then it sends the message to the server. =head2 Presence Functions PresenceSend() - no arguments will send an empty PresenceSend(hash, Presence to the server to tell it signature=>string) that you are available. If you provide a hash, then it will pass that hash to the SetPresence() function as defined in the Net::XMPP::Presence module. Optionally, you can specify a signature and a jabber:x:signed will be placed in the . =head2 Subscription Functions Subscription(hash) - taks the hash and passes it to SetPresence in Net::XMPP::Presence (refer there for valid settings). Then it sends the subscription to server. The valid types of subscription are: subscribe - subscribe to JID's presence unsubscribe - unsubscribe from JID's presence subscribed - response to a subscribe unsubscribed - response to an unsubscribe =head2 Presence DB Functions PresenceDB() - Tell the object to initialize the callbacks to automatically populate the Presence DB. PresenceDBParse(Net::XMPP::Presence) - for every presence that you receive pass the Presence object to the DB so that it can track the resources and priorities for you. Returns either the presence passed in, if it not able to parsed for the DB, or the current presence as found by the PresenceDBQuery function. PresenceDBDelete(string|Net::XMPP::JID) - delete thes JID entry from the DB. PresenceDBClear() - delete all entries in the database. PresenceDBQuery(string|Net::XMPP::JID) - returns the NX::Presence that was last received for the highest priority of this JID. You can pass it a string or a NX::JID object. PresenceDBResources(string|Net::XMPP::JID) - returns an array of resources in order from highest priority to lowest. =head2 IQ Functions =head2 Auth Functions AuthSend(username=>string, - takes all of the information and password=>string, builds a Net::XMPP::IQ::Auth packet. resource=>string) It then sends that packet to the server with an ID and waits for that ID to return. Then it looks in resulting packet and determines if authentication was successful for not. The array returned from AuthSend looks like this: [ type , message ] If type is "ok" then authentication was successful, otherwise message contains a little more detail about the error. =head2 IQ::Register Functions RegisterRequest(to=>string, - send an request to the specified timeout=>int) server/transport, if not specified it RegisterRequest() sends to the current active server. The function returns a hash that contains the required fields. Here is an example of the hash: $hash{fields} - The raw fields from the iq:register. To be used if there is no x:data in the packet. $hash{instructions} - How to fill out the form. $hash{form} - The new dynamic forms. In $hash{form}, the fields that are present are the required fields the server needs. RegisterSend(hash) - takes the contents of the hash and passes it to the SetRegister function in the module Net::XMPP::Query jabber:iq:register namespace. This function returns an array that looks like this: [ type , message ] If type is "ok" then registration was successful, otherwise message contains a little more detail about the error. =head2 Roster Functions Roster() - returns a Net::XMPP::Roster object. This will automatically intercept all of the roster and presence packets sent from the server and give you an accurate Roster. For more information please read the man page for Net::XMPP::Roster. RosterParse(IQ object) - returns a hash that contains the roster parsed into the following data structure: $roster{'bob@jabber.org'}->{name} - Name you stored in the roster $roster{'bob@jabber.org'}->{subscription} - Subscription status (to, from, both, none) $roster{'bob@jabber.org'}->{ask} - The ask status from this user (subscribe, unsubscribe) $roster{'bob@jabber.org'}->{groups} - Array of groups that bob@jabber.org is in RosterGet() - sends an empty Net::XMPP::IQ::Roster tag to the server so the server will send the Roster to the client. Returns the above hash from RosterParse. RosterRequest() - sends an empty Net::XMPP::IQ::Roster tag to the server so the server will send the Roster to the client. RosterAdd(hash) - sends a packet asking that the jid be added to the roster. The hash format is defined in the SetItem function in the Net::XMPP::Query jabber:iq:roster namespace. RosterRemove(hash) - sends a packet asking that the jid be removed from the roster. The hash format is defined in the SetItem function in the Net::XMPP::Query jabber:iq:roster namespace. =head2 Roster DB Functions RosterDB() - Tell the object to initialize the callbacks to automatically populate the Roster DB. If you do this, then make sure that you call RosterRequest() instead of RosterGet() so that the callbacks can catch it and parse it. RosterDBParse(IQ object) - If you want to manually control the database, then you can pass in all iq packets with jabber:iq:roster queries to this function. RosterDBAdd(jid,hash) - Add a new JID into the roster DB. The JID is either a string, or a Net::XMPP::JID object. The hash must be the same format as the has returned by RosterParse above, and is the actual hash, not a reference. RosterDBRemove(jid) - Remove a JID from the roster DB. The JID is either a string, or a Net::XMPP::JID object. RosterDBClear() - Remove all JIDs from the roster DB. RosterDBExists(jid) - return 1 if the JID exists in the roster DB, undef otherwise. The JID is either a string, or a Net::XMPP::JID object. RosterDBJIDs() - returns a list of Net::XMPP::JID objects that represents all of the JIDs in the DB. RosterDBGroups() - returns the complete list of roster groups in the roster. RosterDBGroupExists(group) - return 1 if the group is a group in the roster DB, undef otherwise. RosterDBGroupJIDs(group) - returns a list of Net::XMPP::JID objects that represents all of the JIDs in the specified roster group. RosterDBNonGroupJIDs() - returns a list of Net::XMPP::JID objects that represents all of the JIDs not in a roster group. RosterDBQuery(jid) - returns a hash containing the data from the roster DB for the specified JID. The JID is either a string, or a Net::XMPP::JID object. The hash format the same as in RosterParse above. RosterDBQuery(jid,key) - returns the entry from the above hash for the given key. The available keys are: name, ask, subsrcription and groups The JID is either a string, or a Net::XMPP::JID object. =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut use Net::XMPP::Roster; use Net::XMPP::PrivacyLists; use strict; use Carp; use vars qw( %XMLNS %NEWOBJECT $SASL_CALLBACK $TLS_CALLBACK ); ############################################################################## # Define the namespaces in an easy/constant manner. #----------------------------------------------------------------------------- # 1.0 #----------------------------------------------------------------------------- $XMLNS{'xmppstreams'} = "urn:ietf:params:xml:ns:xmpp-streams"; $XMLNS{'xmpp-bind'} = "urn:ietf:params:xml:ns:xmpp-bind"; $XMLNS{'xmpp-sasl'} = "urn:ietf:params:xml:ns:xmpp-sasl"; $XMLNS{'xmpp-session'} = "urn:ietf:params:xml:ns:xmpp-session"; $XMLNS{'xmpp-tls'} = "urn:ietf:params:xml:ns:xmpp-tls"; ############################################################################## ############################################################################## # BuildObject takes a root tag and builds the correct object. NEWOBJECT is # the table that maps tag to package. Override these, or provide new ones. #----------------------------------------------------------------------------- $NEWOBJECT{'iq'} = "Net::XMPP::IQ"; $NEWOBJECT{'message'} = "Net::XMPP::Message"; $NEWOBJECT{'presence'} = "Net::XMPP::Presence"; $NEWOBJECT{'jid'} = "Net::XMPP::JID"; ############################################################################## sub _message { shift; my $o; eval "\$o = new $NEWOBJECT{'message'}(\@_);"; return $o; } sub _presence { shift; my $o; eval "\$o = new $NEWOBJECT{'presence'}(\@_);"; return $o; } sub _iq { shift; my $o; eval "\$o = new $NEWOBJECT{'iq'}(\@_);"; return $o; } sub _jid { shift; my $o; eval "\$o = new $NEWOBJECT{'jid'}(\@_);"; return $o; } ############################################################################### #+----------------------------------------------------------------------------- #| #| Base API #| #+----------------------------------------------------------------------------- ############################################################################### ############################################################################### # # GetErrorCode - if you are returned an undef, you can call this function # and hopefully learn more information about the problem. # ############################################################################### sub GetErrorCode { my $self = shift; return ((exists($self->{ERRORCODE}) && ($self->{ERRORCODE} ne "")) ? $self->{ERRORCODE} : $! ); } ############################################################################### # # SetErrorCode - sets the error code so that the caller can find out more # information about the problem # ############################################################################### sub SetErrorCode { my $self = shift; my ($errorcode) = @_; $self->{ERRORCODE} = $errorcode; } ############################################################################### # # CallBack - Central callback function. If a packet comes back with an ID # and the tag and ID have been registered then the packet is not # returned as normal, instead it is inserted in the LIST and # stored until the user wants to fetch it. If the tag and ID # are not registered the function checks if a callback exists # for this tag, if it does then that callback is called, # otherwise the function drops the packet since it does not know # how to handle it. # ############################################################################### sub CallBack { my $self = shift; my $sid = shift; my ($object) = @_; my $tag; my $id; my $tree; if (ref($object) !~ /^Net::XMPP/) { if ($self->{DEBUG}->GetLevel() >= 1 || exists($self->{CB}->{receive})) { my $xml = $object->GetXML(); $self->{DEBUG}->Log1("CallBack: sid($sid) received($xml)"); &{$self->{CB}->{receive}}($sid,$xml) if exists($self->{CB}->{receive}); } $tag = $object->get_tag(); $id = ""; $id = $object->get_attrib("id") if defined($object->get_attrib("id")); $tree = $object; } else { $tag = $object->GetTag(); $id = $object->GetID(); $tree = $object->GetTree(); } $self->{DEBUG}->Log1("CallBack: tag($tag)"); $self->{DEBUG}->Log1("CallBack: id($id)") if ($id ne ""); my $pass = 1; $pass = 0 if (!exists($self->{CB}->{$tag}) && !exists($self->{CB}->{XPath}) && !exists($self->{CB}->{DirectXPath}) && !$self->CheckID($tag,$id) ); if ($pass) { $self->{DEBUG}->Log1("CallBack: we either want it or were waiting for it."); if (exists($self->{CB}->{DirectXPath})) { $self->{DEBUG}->Log1("CallBack: check directxpath"); my $direct_pass = 0; foreach my $xpath (keys(%{$self->{CB}->{DirectXPath}})) { $self->{DEBUG}->Log1("CallBack: check directxpath($xpath)"); if ($object->XPathCheck($xpath)) { foreach my $func (keys(%{$self->{CB}->{DirectXPath}->{$xpath}})) { $self->{DEBUG}->Log1("CallBack: goto directxpath($xpath) function($func)"); &{$self->{CB}->{DirectXPath}->{$xpath}->{$func}}($sid,$object); $direct_pass = 1; } } } return if $direct_pass; } my $NXObject; if (ref($object) !~ /^Net::XMPP/) { $NXObject = $self->BuildObject($tag,$object); } else { $NXObject = $object; } if ($NXObject == -1) { $self->{DEBUG}->Log1("CallBack: DANGER!! DANGER!! We didn't build a packet! We're all gonna die!!"); } else { if ($self->CheckID($tag,$id)) { $self->{DEBUG}->Log1("CallBack: found registry entry: tag($tag) id($id)"); $self->DeregisterID($tag,$id); if ($self->TimedOutID($id)) { $self->{DEBUG}->Log1("CallBack: dropping packet due to timeout"); $self->CleanID($id); } else { $self->{DEBUG}->Log1("CallBack: they still want it... we still got it..."); $self->GotID($id,$NXObject); } } else { $self->{DEBUG}->Log1("CallBack: no registry entry"); if (exists($self->{CB}->{XPath})) { $self->{DEBUG}->Log1("CallBack: check xpath"); foreach my $xpath (keys(%{$self->{CB}->{XPath}})) { if ($NXObject->GetTree()->XPathCheck($xpath)) { foreach my $func (keys(%{$self->{CB}->{XPath}->{$xpath}})) { $self->{DEBUG}->Log1("CallBack: goto xpath($xpath) function($func)"); &{$self->{CB}->{XPath}->{$xpath}->{$func}}($sid,$NXObject); } } } } if (exists($self->{CB}->{$tag})) { $self->{DEBUG}->Log1("CallBack: goto user function($self->{CB}->{$tag})"); &{$self->{CB}->{$tag}}($sid,$NXObject); } else { $self->{DEBUG}->Log1("CallBack: no defined function. Dropping packet."); } } } } else { $self->{DEBUG}->Log1("CallBack: a packet that no one wants... how sad. =("); } } ############################################################################### # # BuildObject - turn the packet into an object. # ############################################################################### sub BuildObject { my $self = shift; my ($tag,$tree) = @_; my $obj = -1; if (exists($NEWOBJECT{$tag})) { $self->{DEBUG}->Log1("BuildObject: tag($tag) package($NEWOBJECT{$tag})"); eval "\$obj = new $NEWOBJECT{$tag}(\$tree);"; } return $obj; } ############################################################################### # # SetCallBacks - Takes a hash with top level tags to look for as the keys # and pointers to functions as the values. The functions # are called and passed the XML::Parser::Tree objects # generated by XML::Stream. # ############################################################################### sub SetCallBacks { my $self = shift; while($#_ >= 0) { my $func = pop(@_); my $tag = pop(@_); $self->{DEBUG}->Log1("SetCallBacks: tag($tag) func($func)"); if (defined($func)) { $self->{CB}->{$tag} = $func; } else { delete($self->{CB}->{$tag}); } $self->{STREAM}->SetCallBacks(update=>$func) if ($tag eq "update"); } } ############################################################################### # # SetIQCallBacks - define callbacks for the namespaces inside an iq. # ############################################################################### sub SetIQCallBacks { my $self = shift; while($#_ >= 0) { my $hash = pop(@_); my $namespace = pop(@_); foreach my $type (keys(%{$hash})) { $self->{DEBUG}->Log1("SetIQCallBacks: type($type) func($hash->{$type}) ". "namespace($namespace)"); if (defined($hash->{$type})) { $self->{CB}->{IQns}->{$namespace}->{$type} = $hash->{$type}; } else { delete($self->{CB}->{IQns}->{$namespace}->{$type}); } } } } ############################################################################### # # SetPresenceCallBacks - define callbacks for the different presence packets. # ############################################################################### sub SetPresenceCallBacks { my $self = shift; my (%types) = @_; foreach my $type (keys(%types)) { $self->{DEBUG}->Log1("SetPresenceCallBacks: type($type) func($types{$type})"); if (defined($types{$type})) { $self->{CB}->{Pres}->{$type} = $types{$type}; } else { delete($self->{CB}->{Pres}->{$type}); } } } ############################################################################### # # SetMessageCallBacks - define callbacks for the different message packets. # ############################################################################### sub SetMessageCallBacks { my $self = shift; my (%types) = @_; foreach my $type (keys(%types)) { $self->{DEBUG}->Log1("SetMessageCallBacks: type($type) func($types{$type})"); if (defined($types{$type})) { $self->{CB}->{Mess}->{$type} = $types{$type}; } else { delete($self->{CB}->{Mess}->{$type}); } } } ############################################################################### # # SetXPathCallBacks - define callbacks for packets based on XPath. # ############################################################################### sub SetXPathCallBacks { my $self = shift; my (%xpaths) = @_; foreach my $xpath (keys(%xpaths)) { $self->{DEBUG}->Log1("SetXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); $self->{CB}->{XPath}->{$xpath}->{$xpaths{$xpath}} = $xpaths{$xpath}; } } ############################################################################### # # RemoveXPathCallBacks - remove callbacks for packets based on XPath. # ############################################################################### sub RemoveXPathCallBacks { my $self = shift; my (%xpaths) = @_; foreach my $xpath (keys(%xpaths)) { $self->{DEBUG}->Log1("RemoveXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); delete($self->{CB}->{XPath}->{$xpath}->{$xpaths{$xpath}}); delete($self->{CB}->{XPath}->{$xpath}) if (scalar(keys(%{$self->{CB}->{XPath}->{$xpath}})) == 0); delete($self->{CB}->{XPath}) if (scalar(keys(%{$self->{CB}->{XPath}})) == 0); } } ############################################################################### # # SetDirectXPathCallBacks - define callbacks for packets based on XPath. # ############################################################################### sub SetDirectXPathCallBacks { my $self = shift; my (%xpaths) = @_; foreach my $xpath (keys(%xpaths)) { $self->{DEBUG}->Log1("SetDirectXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); $self->{CB}->{DirectXPath}->{$xpath}->{$xpaths{$xpath}} = $xpaths{$xpath}; } } ############################################################################### # # RemoveDirectXPathCallBacks - remove callbacks for packets based on XPath. # ############################################################################### sub RemoveDirectXPathCallBacks { my $self = shift; my (%xpaths) = @_; foreach my $xpath (keys(%xpaths)) { $self->{DEBUG}->Log1("RemoveDirectXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); delete($self->{CB}->{DirectXPath}->{$xpath}->{$xpaths{$xpath}}); delete($self->{CB}->{DirectXPath}->{$xpath}) if (scalar(keys(%{$self->{CB}->{DirectXPath}->{$xpath}})) == 0); delete($self->{CB}->{DirectXPath}) if (scalar(keys(%{$self->{CB}->{DirectXPath}})) == 0); } } ############################################################################### # # Send - Takes either XML or a Net::XMPP::xxxx object and sends that # packet to the server. # ############################################################################### sub Send { my $self = shift; my $object = shift; my $ignoreActivity = shift; $ignoreActivity = 0 unless defined($ignoreActivity); if (ref($object) eq "") { $self->SendXML($object,$ignoreActivity); } else { $self->SendXML($object->GetXML(),$ignoreActivity); } } ############################################################################### # # SendXML - Sends the XML packet to the server # ############################################################################### sub SendXML { my $self = shift; my $xml = shift; my $ignoreActivity = shift; $ignoreActivity = 0 unless defined($ignoreActivity); $self->{DEBUG}->Log1("SendXML: sent($xml)"); &{$self->{CB}->{send}}($self->GetStreamID(),$xml) if exists($self->{CB}->{send}); $self->{STREAM}->IgnoreActivity($self->GetStreamID(),$ignoreActivity); $self->{STREAM}->Send($self->GetStreamID(),$xml); $self->{STREAM}->IgnoreActivity($self->GetStreamID(),0); } ############################################################################### # # SendWithID - Take either XML or a Net::XMPP::xxxx object and send it # with the next available ID number. Then return that ID so # the client can track it. # ############################################################################### sub SendWithID { my $self = shift; my ($object) = @_; #-------------------------------------------------------------------------- # Take the current XML stream and insert an id attrib at the top level. #-------------------------------------------------------------------------- my $id = $self->UniqueID(); $self->{DEBUG}->Log1("SendWithID: id($id)"); my $xml; if (ref($object) eq "") { $self->{DEBUG}->Log1("SendWithID: in($object)"); $xml = $object; $xml =~ s/^(\<[^\>]+)(\>)/$1 id\=\'$id\'$2/; my ($tag) = ($xml =~ /^\<(\S+)\s/); $self->RegisterID($tag,$id); } else { $self->{DEBUG}->Log1("SendWithID: in(",$object->GetXML(),")"); $object->SetID($id); $xml = $object->GetXML(); $self->RegisterID($object->GetTag(),$id); } $self->{DEBUG}->Log1("SendWithID: out($xml)"); #-------------------------------------------------------------------------- # Send the new XML string. #-------------------------------------------------------------------------- $self->SendXML($xml); #-------------------------------------------------------------------------- # Return the ID number we just assigned. #-------------------------------------------------------------------------- return $id; } ############################################################################### # # UniqueID - Increment and return a new unique ID. # ############################################################################### sub UniqueID { my $self = shift; my $id_num = $self->{RCVDB}->{currentID}; $self->{RCVDB}->{currentID}++; return "netjabber-$id_num"; } ############################################################################### # # SendAndReceiveWithID - Take either XML or a Net::XMPP::xxxxx object and # send it with the next ID. Then wait for that ID # to come back and return the response in a # Net::XMPP::xxxx object. # ############################################################################### sub SendAndReceiveWithID { my $self = shift; my ($object,$timeout) = @_; &{$self->{CB}->{startwait}}() if exists($self->{CB}->{startwait}); $self->{DEBUG}->Log1("SendAndReceiveWithID: object($object)"); my $id = $self->SendWithID($object); $self->{DEBUG}->Log1("SendAndReceiveWithID: sent with id($id)"); my $packet = $self->WaitForID($id,$timeout); &{$self->{CB}->{endwait}}() if exists($self->{CB}->{endwait}); return $packet; } ############################################################################### # # ReceivedID - returns 1 if a packet with the ID has been received, or 0 # if it has not. # ############################################################################### sub ReceivedID { my $self = shift; my ($id) = @_; $self->{DEBUG}->Log1("ReceivedID: id($id)"); return 1 if exists($self->{RCVDB}->{$id}); $self->{DEBUG}->Log1("ReceivedID: nope..."); return 0; } ############################################################################### # # GetID - Return the Net::XMPP::xxxxx object that is stored in the LIST # that matches the ID if that ID exists. Otherwise return 0. # ############################################################################### sub GetID { my $self = shift; my ($id) = @_; $self->{DEBUG}->Log1("GetID: id($id)"); return $self->{RCVDB}->{$id} if $self->ReceivedID($id); $self->{DEBUG}->Log1("GetID: haven't gotten that id yet..."); return 0; } ############################################################################### # # CleanID - Delete the list entry for this id since we don't want a leak. # ############################################################################### sub CleanID { my $self = shift; my ($id) = @_; $self->{DEBUG}->Log1("CleanID: id($id)"); delete($self->{RCVDB}->{$id}); } ############################################################################### # # WaitForID - Keep looping and calling Process(1) to poll every second # until the response from the server occurs. # ############################################################################### sub WaitForID { my $self = shift; my ($id,$timeout) = @_; $timeout = "300" unless defined($timeout); $self->{DEBUG}->Log1("WaitForID: id($id)"); my $endTime = time + $timeout; while(!$self->ReceivedID($id) && ($endTime >= time)) { $self->{DEBUG}->Log1("WaitForID: haven't gotten it yet... let's wait for more packets"); return unless (defined($self->Process(1))); &{$self->{CB}->{update}}() if exists($self->{CB}->{update}); } if (!$self->ReceivedID($id)) { $self->TimeoutID($id); $self->{DEBUG}->Log1("WaitForID: timed out..."); return; } else { $self->{DEBUG}->Log1("WaitForID: we got it!"); my $packet = $self->GetID($id); $self->CleanID($id); return $packet; } } ############################################################################### # # GotID - Callback to store the Net::XMPP::xxxxx object in the LIST at # the ID index. This is a private helper function. # ############################################################################### sub GotID { my $self = shift; my ($id,$object) = @_; $self->{DEBUG}->Log1("GotID: id($id) xml(",$object->GetXML(),")"); $self->{RCVDB}->{$id} = $object; } ############################################################################### # # CheckID - Checks the ID registry if this tag and ID have been registered. # 0 = no, 1 = yes # ############################################################################### sub CheckID { my $self = shift; my ($tag,$id) = @_; $id = "" unless defined($id); $self->{DEBUG}->Log1("CheckID: tag($tag) id($id)"); return 0 if ($id eq ""); $self->{DEBUG}->Log1("CheckID: we have that here somewhere..."); return exists($self->{IDRegistry}->{$tag}->{$id}); } ############################################################################### # # TimeoutID - Timeout the tag and ID in the registry so that the CallBack # can know what to put in the ID list and what to pass on. # ############################################################################### sub TimeoutID { my $self = shift; my ($id) = @_; $self->{DEBUG}->Log1("TimeoutID: id($id)"); $self->{RCVDB}->{$id} = 0; } ############################################################################### # # TimedOutID - Timeout the tag and ID in the registry so that the CallBack # can know what to put in the ID list and what to pass on. # ############################################################################### sub TimedOutID { my $self = shift; my ($id) = @_; return (exists($self->{RCVDB}->{$id}) && ($self->{RCVDB}->{$id} == 0)); } ############################################################################### # # RegisterID - Register the tag and ID in the registry so that the CallBack # can know what to put in the ID list and what to pass on. # ############################################################################### sub RegisterID { my $self = shift; my ($tag,$id) = @_; $self->{DEBUG}->Log1("RegisterID: tag($tag) id($id)"); $self->{IDRegistry}->{$tag}->{$id} = 1; } ############################################################################### # # DeregisterID - Delete the tag and ID in the registry so that the CallBack # can knows that it has been received. # ############################################################################### sub DeregisterID { my $self = shift; my ($tag,$id) = @_; $self->{DEBUG}->Log1("DeregisterID: tag($tag) id($id)"); delete($self->{IDRegistry}->{$tag}->{$id}); } ############################################################################### # # AddNamespace - Add a custom namespace into the mix. # ############################################################################### sub AddNamespace { my $self = shift; &Net::XMPP::Namespaces::add_ns(@_); } ############################################################################### # # MessageSend - Takes the same hash that Net::XMPP::Message->SetMessage # takes and sends the message to the server. # ############################################################################### sub MessageSend { my $self = shift; my $mess = $self->_message(); $mess->SetMessage(@_); $self->Send($mess); } ############################################################################## # # PresenceDB - initialize the module to use the presence database # ############################################################################## sub PresenceDB { my $self = shift; $self->SetXPathCallBacks('/presence'=>sub{ shift; $self->PresenceDBParse(@_) }); } ############################################################################### # # PresenceDBParse - adds the presence information to the Presence DB so # you can keep track of the current state of the JID and # all of it's resources. # ############################################################################### sub PresenceDBParse { my $self = shift; my ($presence) = @_; $self->{DEBUG}->Log4("PresenceDBParse: pres(",$presence->GetXML(),")"); my $type = $presence->GetType(); $type = "" unless defined($type); return $presence unless (($type eq "") || ($type eq "available") || ($type eq "unavailable")); my $fromJID = $presence->GetFrom("jid"); my $fromID = $fromJID->GetJID(); $fromID = "" unless defined($fromID); my $resource = $fromJID->GetResource(); $resource = " " unless ($resource ne ""); my $priority = $presence->GetPriority(); $priority = 0 unless defined($priority); $self->{DEBUG}->Log1("PresenceDBParse: fromJID(",$fromJID->GetJID("full"),") resource($resource) priority($priority) type($type)"); $self->{DEBUG}->Log2("PresenceDBParse: xml(",$presence->GetXML(),")"); if (exists($self->{PRESENCEDB}->{$fromID})) { my $oldPriority = $self->{PRESENCEDB}->{$fromID}->{resources}->{$resource}; $oldPriority = "" unless defined($oldPriority); my $loc = 0; foreach my $index (0..$#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}}) { $loc = $index if ($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}->[$index]->{resource} eq $resource); } splice(@{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}},$loc,1); delete($self->{PRESENCEDB}->{$fromID}->{resources}->{$resource}); delete($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}) if (exists($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}) && ($#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}} == -1)); delete($self->{PRESENCEDB}->{$fromID}) if (scalar(keys(%{$self->{PRESENCEDB}->{$fromID}})) == 0); $self->{DEBUG}->Log1("PresenceDBParse: remove ",$fromJID->GetJID("full")," from the DB"); } if (($type eq "") || ($type eq "available")) { my $loc = -1; foreach my $index (0..$#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}}) { $loc = $index if ($self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$index]->{resource} eq $resource); } $loc = $#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}}+1 if ($loc == -1); $self->{PRESENCEDB}->{$fromID}->{resources}->{$resource} = $priority; $self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$loc]->{presence} = $presence; $self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$loc]->{resource} = $resource; $self->{DEBUG}->Log1("PresenceDBParse: add ",$fromJID->GetJID("full")," to the DB"); } my $currentPresence = $self->PresenceDBQuery($fromJID); return (defined($currentPresence) ? $currentPresence : $presence); } ############################################################################### # # PresenceDBDelete - delete the JID from the DB completely. # ############################################################################### sub PresenceDBDelete { my $self = shift; my ($jid) = @_; my $indexJID = $jid; $indexJID = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); return if !exists($self->{PRESENCEDB}->{$indexJID}); delete($self->{PRESENCEDB}->{$indexJID}); $self->{DEBUG}->Log1("PresenceDBDelete: delete ",$indexJID," from the DB"); } ############################################################################### # # PresenceDBClear - delete all of the JIDs from the DB completely. # ############################################################################### sub PresenceDBClear { my $self = shift; $self->{DEBUG}->Log1("PresenceDBClear: clearing the database"); foreach my $indexJID (keys(%{$self->{PRESENCEDB}})) { $self->{DEBUG}->Log3("PresenceDBClear: deleting ",$indexJID," from the DB"); delete($self->{PRESENCEDB}->{$indexJID}); } $self->{DEBUG}->Log3("PresenceDBClear: database is empty"); } ############################################################################### # # PresenceDBQuery - retrieve the last Net::XMPP::Presence received with # the highest priority. # ############################################################################### sub PresenceDBQuery { my $self = shift; my ($jid) = @_; my $indexJID = $jid; $indexJID = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); return if !exists($self->{PRESENCEDB}->{$indexJID}); return if (scalar(keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}})) == 0); my $highPriority = (sort {$b cmp $a} keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}}))[0]; return $self->{PRESENCEDB}->{$indexJID}->{priorities}->{$highPriority}->[0]->{presence}; } ############################################################################### # # PresenceDBResources - returns a list of the resources from highest # priority to lowest. # ############################################################################### sub PresenceDBResources { my $self = shift; my ($jid) = @_; my $indexJID = $jid; $indexJID = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); my @resources; return if !exists($self->{PRESENCEDB}->{$indexJID}); foreach my $priority (sort {$b cmp $a} keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}})) { foreach my $index (0..$#{$self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}}) { next if ($self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}->[$index]->{resource} eq " "); push(@resources,$self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}->[$index]->{resource}); } } return @resources; } ############################################################################### # # PresenceSend - Sends a presence tag to announce your availability # ############################################################################### sub PresenceSend { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $args{ignoreactivity} = 0 unless exists($args{ignoreactivity}); my $ignoreActivity = delete($args{ignoreactivity}); my $presence = $self->_presence(); $presence->SetPresence(%args); $self->Send($presence,$ignoreActivity); return $presence; } ############################################################################### # # PresenceProbe - Sends a presence probe to the server # ############################################################################### sub PresenceProbe { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } delete($args{type}); my $presence = $self->_presence(); $presence->SetPresence(type=>"probe", %args); $self->Send($presence); } ############################################################################### # # Subscription - Sends a presence tag to perform the subscription on the # specified JID. # ############################################################################### sub Subscription { my $self = shift; my $presence = $self->_presence(); $presence->SetPresence(@_); $self->Send($presence); } ############################################################################### # # AuthSend - This is a self contained function to send a login iq tag with # an id. Then wait for a reply what the same id to come back # and tell the caller what the result was. # ############################################################################### sub AuthSend { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } carp("AuthSend requires a username arguement") unless exists($args{username}); carp("AuthSend requires a password arguement") unless exists($args{password}); if($self->{STREAM}->GetStreamFeature($self->GetStreamID(),"xmpp-sasl")) { return $self->AuthSASL(%args); } return $self->AuthIQAuth(%args); } ############################################################################### # # AuthIQAuth - Try and auth using jabber:iq:auth, the old Jabber way of # authenticating. # ############################################################################### sub AuthIQAuth { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $self->{DEBUG}->Log1("AuthIQAuth: old school auth"); carp("AuthIQAuth requires a resource arguement") unless exists($args{resource}); my $authType = "digest"; my $token; my $sequence; #-------------------------------------------------------------------------- # First let's ask the sever what all is available in terms of auth types. # If we get an error, then all we can do is digest or plain. #-------------------------------------------------------------------------- my $iqAuth = $self->_iq(); $iqAuth->SetIQ(type=>"get"); my $iqAuthQuery = $iqAuth->NewChild("jabber:iq:auth"); $iqAuthQuery->SetUsername($args{username}); $iqAuth = $self->SendAndReceiveWithID($iqAuth); return unless defined($iqAuth); return ( $iqAuth->GetErrorCode() , $iqAuth->GetError() ) if ($iqAuth->GetType() eq "error"); if ($iqAuth->GetType() eq "error") { $authType = "digest"; } else { $iqAuthQuery = $iqAuth->GetChild(); $authType = "plain" if $iqAuthQuery->DefinedPassword(); $authType = "digest" if $iqAuthQuery->DefinedDigest(); $authType = "zerok" if ($iqAuthQuery->DefinedSequence() && $iqAuthQuery->DefinedToken()); $token = $iqAuthQuery->GetToken() if ($authType eq "zerok"); $sequence = $iqAuthQuery->GetSequence() if ($authType eq "zerok"); } $self->{DEBUG}->Log1("AuthIQAuth: authType($authType)"); delete($args{digest}); delete($args{type}); #-------------------------------------------------------------------------- # 0k authenticaion (http://core.jabber.org/0k.html) # # Tell the server that we want to connect this way, the server sends back # a token and a sequence number. We take that token + the password and # SHA1 it. Then we SHA1 it sequence number more times and send that hash. # The server SHA1s that hash one more time and compares it to the hash it # stored last time. IF they match, we are in and it stores the hash we sent # for the next time and decreases the sequence number, else, no go. #-------------------------------------------------------------------------- if ($authType eq "zerok") { my $hashA = Digest::SHA1::sha1_hex(delete($args{password})); $args{hash} = Digest::SHA1::sha1_hex($hashA.$token); for (1..$sequence) { $args{hash} = Digest::SHA1::sha1_hex($args{hash}); } } #-------------------------------------------------------------------------- # If we have access to the SHA-1 digest algorithm then let's use it. # Remove the password from the hash, create the digest, and put the # digest in the hash instead. # # Note: Concat the Session ID and the password and then digest that # string to get the server to accept the digest. #-------------------------------------------------------------------------- if ($authType eq "digest") { my $password = delete($args{password}); $args{digest} = Digest::SHA1::sha1_hex($self->GetStreamID().$password); } #-------------------------------------------------------------------------- # Create a Net::XMPP::IQ object to send to the server #-------------------------------------------------------------------------- my $iqLogin = $self->_iq(); $iqLogin->SetIQ(type=>"set"); my $iqLoginQuery = $iqLogin->NewChild("jabber:iq:auth"); $iqLoginQuery->SetAuth(%args); #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- $iqLogin = $self->SendAndReceiveWithID($iqLogin); #-------------------------------------------------------------------------- # From the reply IQ determine if we were successful or not. If yes then # return "". If no then return error string from the reply. #-------------------------------------------------------------------------- return unless defined($iqLogin); return ( $iqLogin->GetErrorCode() , $iqLogin->GetError() ) if ($iqLogin->GetType() eq "error"); $self->{DEBUG}->Log1("AuthIQAuth: we authed!"); return ("ok",""); } ############################################################################### # # AuthSASL - Try and auth using SASL, the XMPP preferred way of authenticating. # ############################################################################### sub AuthSASL { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $self->{DEBUG}->Log1("AuthSASL: shiney new auth"); carp("AuthSASL requires a username arguement") unless exists($args{username}); carp("AuthSASL requires a password arguement") unless exists($args{password}); $args{resource} = "" unless exists($args{resource}); #------------------------------------------------------------------------- # Create the SASLClient on our end #------------------------------------------------------------------------- my $sid = $self->{SESSION}->{id}; my $status = $self->{STREAM}->SASLClient($sid, $args{username}, $args{password} ); $args{timeout} = "120" unless exists($args{timeout}); #------------------------------------------------------------------------- # While we haven't timed out, keep waiting for the SASLClient to finish #------------------------------------------------------------------------- my $endTime = time + $args{timeout}; while(!$self->{STREAM}->SASLClientDone($sid) && ($endTime >= time)) { $self->{DEBUG}->Log1("AuthSASL: haven't authed yet... let's wait."); return unless (defined($self->Process(1))); &{$self->{CB}->{update}}() if exists($self->{CB}->{update}); } #------------------------------------------------------------------------- # The loop finished... but was it done? #------------------------------------------------------------------------- if (!$self->{STREAM}->SASLClientDone($sid)) { $self->{DEBUG}->Log1("AuthSASL: timed out..."); return( "system","SASL timed out authenticating"); } #------------------------------------------------------------------------- # Ok, it was done... but did we auth? #------------------------------------------------------------------------- if (!$self->{STREAM}->SASLClientAuthed($sid)) { $self->{DEBUG}->Log1("AuthSASL: Authentication failed."); return ( "error", $self->{STREAM}->SASLClientError($sid)); } #------------------------------------------------------------------------- # Phew... Restart the per XMPP #------------------------------------------------------------------------- $self->{DEBUG}->Log1("AuthSASL: We authed!"); $self->{SESSION} = $self->{STREAM}->OpenStream($sid); $sid = $self->{SESSION}->{id}; $self->{DEBUG}->Log1("AuthSASL: We got a new session. sid($sid)"); #------------------------------------------------------------------------- # Look in the new set of s and see if xmpp-bind was # offered. #------------------------------------------------------------------------- my $bind = $self->{STREAM}->GetStreamFeature($sid,"xmpp-bind"); if ($bind) { $self->{DEBUG}->Log1("AuthSASL: Binding to resource"); $self->BindResource($args{resource}); } #------------------------------------------------------------------------- # Look in the new set of s and see if xmpp-session was # offered. #------------------------------------------------------------------------- my $session = $self->{STREAM}->GetStreamFeature($sid,"xmpp-session"); if ($session) { $self->{DEBUG}->Log1("AuthSASL: Starting session"); $self->StartSession(); } return ("ok",""); } ############################################################################## # # BindResource - bind to a resource # ############################################################################## sub BindResource { my $self = shift; my $resource = shift; $self->{DEBUG}->Log2("BindResource: Binding to resource"); my $iq = $self->_iq(); $iq->SetIQ(type=>"set"); my $bind = $iq->NewChild(&ConstXMLNS("xmpp-bind")); if (defined($resource) && ($resource ne "")) { $self->{DEBUG}->Log2("BindResource: resource($resource)"); $bind->SetBind(resource=>$resource); } my $result = $self->SendAndReceiveWithID($iq); } ############################################################################## # # StartSession - Initialize a session # ############################################################################## sub StartSession { my $self = shift; my $iq = $self->_iq(); $iq->SetIQ(type=>"set"); my $session = $iq->NewChild(&ConstXMLNS("xmpp-session")); my $result = $self->SendAndReceiveWithID($iq); } ############################################################################## # # PrivacyLists - Initialize a Net::XMPP::PrivacyLists object and return it. # ############################################################################## sub PrivacyLists { my $self = shift; return new Net::XMPP::PrivacyLists(connection=>$self); } ############################################################################## # # PrivacyListsGet - Sends an empty IQ to the server to request that the user's # Privacy Lists be sent to them. Returns the iq packet # of the result. # ############################################################################## sub PrivacyListsGet { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $iq = $self->_iq(); $iq->SetIQ(type=>"get"); my $query = $iq->NewChild("jabber:iq:privacy"); if (exists($args{list})) { $query->AddList(name=>$args{list}); } $iq = $self->SendAndReceiveWithID($iq); return unless defined($iq); return $iq; } ############################################################################## # # PrivacyListsRequest - Sends an empty IQ to the server to request that the # user's privacy lists be sent to them, and return to # let the user's program handle parsing the return packet. # ############################################################################## sub PrivacyListsRequest { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $iq = $self->_iq(); $iq->SetIQ(type=>"get"); my $query = $iq->NewChild("jabber:iq:privacy"); if (exists($args{list})) { $query->AddList(name=>$args{list}); } $self->Send($iq); } ############################################################################## # # PrivacyListsSet - Sends an empty IQ to the server to request that the # user's privacy lists be sent to them, and return to # let the user's program handle parsing the return packet. # ############################################################################## sub PrivacyListsSet { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $iq = $self->_iq(); $iq->SetIQ(type=>"set"); my $query = $iq->NewChild("jabber:iq:privacy"); #XXX error check that there is a list my $list = $query->AddList(name=>$args{list}); foreach my $item (@{$args{items}}) { $list->AddItem(%{$item}); } $iq = $self->SendAndReceiveWithID($iq); return unless defined($iq); return if $iq->DefinedError(); return 1; } ############################################################################### # # RegisterRequest - This is a self contained function to send an iq tag # an id that requests the target address to send back # the required fields. It waits for a reply what the # same id to come back and tell the caller what the # fields are. # ############################################################################### sub RegisterRequest { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; #-------------------------------------------------------------------------- # Create a Net::XMPP::IQ object to send to the server #-------------------------------------------------------------------------- my $iq = $self->_iq(); $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); $iq->SetIQ(type=>"get"); my $query = $iq->NewChild("jabber:iq:register"); #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); #-------------------------------------------------------------------------- # Check if there was an error. #-------------------------------------------------------------------------- return unless defined($iq); if ($iq->GetType() eq "error") { $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); return; } my %register; #-------------------------------------------------------------------------- # From the reply IQ determine what fields are required and send a hash # back with the fields and any values that are already defined (like key) #-------------------------------------------------------------------------- $query = $iq->GetChild(); $register{fields} = { $query->GetRegister() }; return %register; } ############################################################################### # # RegisterSend - This is a self contained function to send a registration # iq tag with an id. Then wait for a reply what the same # id to come back and tell the caller what the result was. # ############################################################################### sub RegisterSend { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } #-------------------------------------------------------------------------- # Create a Net::XMPP::IQ object to send to the server #-------------------------------------------------------------------------- my $iq = $self->_iq(); $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); $iq->SetIQ(type=>"set"); my $iqRegister = $iq->NewChild("jabber:iq:register"); $iqRegister->SetRegister(%args); #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- $iq = $self->SendAndReceiveWithID($iq); #-------------------------------------------------------------------------- # From the reply IQ determine if we were successful or not. If yes then # return "". If no then return error string from the reply. #-------------------------------------------------------------------------- return unless defined($iq); return ( $iq->GetErrorCode() , $iq->GetError() ) if ($iq->GetType() eq "error"); return ("ok",""); } ############################################################################## # # RosterAdd - Takes the Jabber ID of the user to add to their Roster and # sends the IQ packet to the server. # ############################################################################## sub RosterAdd { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $iq = $self->_iq(); $iq->SetIQ(type=>"set"); my $roster = $iq->NewChild("jabber:iq:roster"); my $item = $roster->AddItem(); $item->SetItem(%args); $self->{DEBUG}->Log1("RosterAdd: xml(",$iq->GetXML(),")"); $self->Send($iq); } ############################################################################## # # RosterAdd - Takes the Jabber ID of the user to remove from their Roster # and sends the IQ packet to the server. # ############################################################################## sub RosterRemove { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } delete($args{subscription}); my $iq = $self->_iq(); $iq->SetIQ(type=>"set"); my $roster = $iq->NewChild("jabber:iq:roster"); my $item = $roster->AddItem(); $item->SetItem(%args, subscription=>"remove"); $self->Send($iq); } ############################################################################## # # RosterParse - Returns a hash of roster items. # ############################################################################## sub RosterParse { my $self = shift; my($iq) = @_; my %roster; my $query = $iq->GetChild("jabber:iq:roster"); if (defined($query)) #$query->GetXMLNS() eq "jabber:iq:roster") { my @items = $query->GetItems(); foreach my $item (@items) { my $jid = $item->GetJID(); $roster{$jid}->{name} = $item->GetName(); $roster{$jid}->{subscription} = $item->GetSubscription(); $roster{$jid}->{ask} = $item->GetAsk(); $roster{$jid}->{groups} = [ $item->GetGroup() ]; } } return %roster; } ############################################################################## # # RosterGet - Sends an empty IQ to the server to request that the user's # Roster be sent to them. Returns a hash of roster items. # ############################################################################## sub RosterGet { my $self = shift; my $iq = $self->_iq(); $iq->SetIQ(type=>"get"); my $query = $iq->NewChild("jabber:iq:roster"); $iq = $self->SendAndReceiveWithID($iq); return unless defined($iq); return $self->RosterParse($iq); } ############################################################################## # # RosterRequest - Sends an empty IQ to the server to request that the user's # Roster be sent to them, and return to let the user's program # handle parsing the return packet. # ############################################################################## sub RosterRequest { my $self = shift; my $iq = $self->_iq(); $iq->SetIQ(type=>"get"); my $query = $iq->NewChild("jabber:iq:roster"); $self->Send($iq); } ############################################################################## # # Roster - Initialize a Net::XMPP::Roster object and return it. # ############################################################################## sub Roster { my $self = shift; return new Net::XMPP::Roster(connection=>$self); } ############################################################################## # # RosterDB - initialize the module to use the roster database # ############################################################################## sub RosterDB { my $self = shift; $self->SetXPathCallBacks('/iq[@type="result" or @type="set"]/query[@xmlns="jabber:iq:roster"]'=>sub{ shift; $self->RosterDBParse(@_) }); } ############################################################################## # # RosterDBAdd - adds the entry to the Roster DB. # ############################################################################## sub RosterDBAdd { my $self = shift; my ($jid,%item) = @_; $self->{ROSTERDB}->{JIDS}->{$jid} = \%item; foreach my $group (@{$item{groups}}) { $self->{ROSTERDB}->{GROUPS}->{$group}->{$jid} = 1; } } ############################################################################### # # RosterDBClear - delete all of the JIDs from the DB completely. # ############################################################################### sub RosterDBClear { my $self = shift; $self->{DEBUG}->Log1("RosterDBClear: clearing the database"); foreach my $jid ($self->RosterDBJIDs()) { $self->{DEBUG}->Log3("RosterDBClear: deleting ",$jid->GetJID()," from the DB"); $self->RosterDBRemove($jid); } $self->{DEBUG}->Log3("RosterDBClear: database is empty"); } ############################################################################## # # RosterDBExists - allows you to query if the JID exists in the Roster DB. # ############################################################################## sub RosterDBExists { my $self = shift; my ($jid) = @_; if ($jid->isa("Net::XMPP::JID")) { $jid = $jid->GetJID(); } return unless exists($self->{ROSTERDB}); return unless exists($self->{ROSTERDB}->{JIDS}); return unless exists($self->{ROSTERDB}->{JIDS}->{$jid}); return 1; } ############################################################################## # # RosterDBGroupExists - allows you to query if the group exists in the Roster # DB. # ############################################################################## sub RosterDBGroupExists { my $self = shift; my ($group) = @_; return unless exists($self->{ROSTERDB}); return unless exists($self->{ROSTERDB}->{GROUPS}); return unless exists($self->{ROSTERDB}->{GROUPS}->{$group}); return 1; } ############################################################################## # # RosterDBGroupJIDs - returns a list of the current groups in your roster. # ############################################################################## sub RosterDBGroupJIDs { my $self = shift; my $group = shift; return unless $self->RosterDBGroupExists($group); my @jids; foreach my $jid (keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}})) { push(@jids,$self->_jid($jid)); } return @jids; } ############################################################################## # # RosterDBGroups - returns a list of the current groups in your roster. # ############################################################################## sub RosterDBGroups { my $self = shift; return () unless exists($self->{ROSTERDB}->{GROUPS}); return () if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0); return keys(%{$self->{ROSTERDB}->{GROUPS}}); } ############################################################################## # # RosterDBJIDs - returns a list of all of the JIDs in your roster. # ############################################################################## sub RosterDBJIDs { my $self = shift; my $group = shift; my @jids; return () unless exists($self->{ROSTERDB}); return () unless exists($self->{ROSTERDB}->{JIDS}); foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}})) { push(@jids,$self->_jid($jid)); } return @jids; } ############################################################################## # # RosterDBNonGroupJIDs - returns a list of the JIDs not in a group. # ############################################################################## sub RosterDBNonGroupJIDs { my $self = shift; my $group = shift; my @jids; return () unless exists($self->{ROSTERDB}); return () unless exists($self->{ROSTERDB}->{JIDS}); foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}})) { next if (exists($self->{ROSTERDB}->{JIDS}->{$jid}->{groups}) && ($#{$self->{ROSTERDB}->{JIDS}->{$jid}->{groups}} > -1)); push(@jids,$self->_jid($jid)); } return @jids; } ############################################################################## # # RosterDBParse - takes an iq packet that containsa roster, parses it, and puts # the roster into the Roster DB. # ############################################################################## sub RosterDBParse { my $self = shift; my ($iq) = @_; #print "RosterDBParse: iq(",$iq->GetXML(),")\n"; my $type = $iq->GetType(); return unless (($type eq "set") || ($type eq "result")); my %newroster = $self->RosterParse($iq); $self->RosterDBProcessParsed(%newroster); } ############################################################################## # # RosterDBProcessParsed - takes a parsed roster and puts it into the Roster DB. # ############################################################################## sub RosterDBProcessParsed { my $self = shift; my (%roster) = @_; foreach my $jid (keys(%roster)) { $self->RosterDBRemove($jid); if ($roster{$jid}->{subscription} ne "remove") { $self->RosterDBAdd($jid, %{$roster{$jid}} ); } } } ############################################################################## # # RosterDBQuery - allows you to get one of the pieces of info from the # Roster DB. # ############################################################################## sub RosterDBQuery { my $self = shift; my $jid = shift; my $key = shift; if ($jid->isa("Net::XMPP::JID")) { $jid = $jid->GetJID(); } return unless $self->RosterDBExists($jid); if (defined($key)) { return unless exists($self->{ROSTERDB}->{JIDS}->{$jid}->{$key}); return $self->{ROSTERDB}->{JIDS}->{$jid}->{$key}; } return %{$self->{ROSTERDB}->{JIDS}->{$jid}}; } ############################################################################## # # RosterDBRemove - removes the JID from the Roster DB. # ############################################################################## sub RosterDBRemove { my $self = shift; my ($jid) = @_; if ($self->RosterDBExists($jid)) { if (defined($self->RosterDBQuery($jid,"groups"))) { foreach my $group (@{$self->RosterDBQuery($jid,"groups")}) { delete($self->{ROSTERDB}->{GROUPS}->{$group}->{$jid}); delete($self->{ROSTERDB}->{GROUPS}->{$group}) if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}})) == 0); delete($self->{ROSTERDB}->{GROUPS}) if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0); } } delete($self->{ROSTERDB}->{JIDS}->{$jid}); } } ############################################################################## #+---------------------------------------------------------------------------- #| #| TLS Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # TLSInit - Initialize the connection for TLS. # ############################################################################## sub TLSInit { my $self = shift; $TLS_CALLBACK = sub{ $self->ProcessTLSStanza( @_ ) }; $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-tls").'"]'=>$TLS_CALLBACK); } ############################################################################## # # ProcessTLSStanza - process a TLS based packet. # ############################################################################## sub ProcessTLSStanza { my $self = shift; my $sid = shift; my $node = shift; my $tag = &XML::Stream::XPath($node,"name()"); if ($tag eq "failure") { $self->TLSClientFailure($node); } if ($tag eq "proceed") { $self->TLSClientProceed($node); } } ############################################################################## # # TLSStart - client function to have the socket start TLS. # ############################################################################## sub TLSStart { my $self = shift; my $timeout = shift; $timeout = 120 unless defined($timeout); $timeout = 120 if ($timeout eq ""); $self->TLSSendStartTLS(); my $endTime = time + $timeout; while(!$self->TLSClientDone() && ($endTime >= time)) { $self->Process(); } if (!$self->TLSClientSecure()) { return; } $self->RestartStream($timeout); } ############################################################################## # # TLSClientProceed - handle a packet. # ############################################################################## sub TLSClientProceed { my $self = shift; my $node = shift; my ($status,$message) = $self->{STREAM}->StartTLS($self->GetStreamID()); if ($status) { $self->{TLS}->{done} = 1; $self->{TLS}->{secure} = 1; } else { $self->{TLS}->{done} = 1; $self->{TLS}->{error} = $message; } $self->RemoveDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-tls").'"]'=>$TLS_CALLBACK); } ############################################################################## # # TLSClientSecure - return 1 if the socket is secure, 0 otherwise. # ############################################################################## sub TLSClientSecure { my $self = shift; return $self->{TLS}->{secure}; } ############################################################################## # # TLSClientDone - return 1 if the TLS process is done # ############################################################################## sub TLSClientDone { my $self = shift; return $self->{TLS}->{done}; } ############################################################################## # # TLSClientError - return the TLS error if any # ############################################################################## sub TLSClientError { my $self = shift; return $self->{TLS}->{error}; } ############################################################################## # # TLSClientFailure - handle a # ############################################################################## sub TLSClientFailure { my $self = shift; my $node = shift; my $type = &XML::Stream::XPath($node,"*/name()"); $self->{TLS}->{error} = $type; $self->{TLS}->{done} = 1; } ############################################################################## # # TLSSendFailure - Send a in the TLS namespace # ############################################################################## sub TLSSendFailure { my $self = shift; my $type = shift; $self->Send("<${type}/>"); } ############################################################################## # # TLSSendStartTLS - send a in the TLS namespace. # ############################################################################## sub TLSSendStartTLS { my $self = shift; $self->Send(""); } ############################################################################## #+---------------------------------------------------------------------------- #| #| SASL Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # SASLInit - Initialize the connection for SASL. # ############################################################################## sub SASLInit { my $self = shift; $SASL_CALLBACK = sub{ $self->ProcessSASLStanza( @_ ) }; $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-sasl").'"]'=> $SASL_CALLBACK); } ############################################################################## # # ProcessSASLStanza - process a SASL based packet. # ############################################################################## sub ProcessSASLStanza { my $self = shift; my $sid = shift; my $node = shift; my $tag = &XML::Stream::XPath($node,"name()"); if ($tag eq "challenge") { $self->SASLAnswerChallenge($node); } if ($tag eq "failure") { $self->SASLClientFailure($node); } if ($tag eq "success") { $self->SASLClientSuccess($node); } } ############################################################################## # # SASLAnswerChallenge - when we get a we need to do the grunt # work to return a . # ############################################################################## sub SASLAnswerChallenge { my $self = shift; my $node = shift; my $challenge64 = &XML::Stream::XPath($node,"text()"); my $challenge = MIME::Base64::decode_base64($challenge64); my $response = $self->SASLGetClient()->client_step($challenge); my $response64 = MIME::Base64::encode_base64($response,""); $self->SASLSendResponse($response64); } ############################################################################### # # SASLClient - This is a helper function to perform all of the required steps # for doing SASL with the server. # ############################################################################### sub SASLClient { my $self = shift; my $username = shift; my $password = shift; my $mechanisms = $self->GetStreamFeature("xmpp-sasl"); return unless defined($mechanisms); my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}), callback=>{ user => $username, pass => $password } ); $self->{SASL}->{client} = $sasl->client_new(); $self->{SASL}->{username} = $username; $self->{SASL}->{password} = $password; $self->{SASL}->{authed} = 0; $self->{SASL}->{done} = 0; $self->SASLSendAuth(); } ############################################################################## # # SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise # ############################################################################## sub SASLClientAuthed { my $self = shift; return $self->{SASL}->{authed}; } ############################################################################## # # SASLClientDone - return 1 if the SASL process is finished # ############################################################################## sub SASLClientDone { my $self = shift; return $self->{SASL}->{done}; } ############################################################################## # # SASLClientError - return the error if any # ############################################################################## sub SASLClientError { my $self = shift; return $self->{SASL}->{error}; } ############################################################################## # # SASLClientFailure - handle a received # ############################################################################## sub SASLClientFailure { my $self = shift; my $node = shift; my $type = &XML::Stream::XPath($node,"*/name()"); $self->{SASL}->{error} = $type; $self->{SASL}->{done} = 1; } ############################################################################## # # SASLClientSuccess - handle a received # ############################################################################## sub SASLClientSuccess { my $self = shift; my $node = shift; $self->{SASL}->{authed} = 1; $self->{SASL}->{done} = 1; $self->RemoveDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-sasl").'"]'=>$SASL_CALLBACK); } ############################################################################### # # SASLGetClient - This is a helper function to return the SASL client object. # ############################################################################### sub SASLGetClient { my $self = shift; return $self->{SASL}->{client}; } ############################################################################## # # SASLSendAuth - send an in the SASL namespace # ############################################################################## sub SASLSendAuth { my $self = shift; $self->Send(""); } ############################################################################## # # SASLSendChallenge - Send a in the SASL namespace # ############################################################################## sub SASLSendChallenge { my $self = shift; my $challenge = shift; $self->Send("${challenge}"); } ############################################################################## # # SASLSendFailure - Send a tag in the SASL namespace # ############################################################################## sub SASLSendFailure { my $self = shift; my $type = shift; $self->Send("<${type}/>"); } ############################################################################## # # SASLSendResponse - Send a tag in the SASL namespace # ############################################################################## sub SASLSendResponse { my $self = shift; my $response = shift; $self->Send("${response}"); } ############################################################################## #+---------------------------------------------------------------------------- #| #| Default CallBacks #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # xmppCallbackInit - initialize the default callbacks # ############################################################################## sub xmppCallbackInit { my $self = shift; $self->{DEBUG}->Log1("xmppCallbackInit: start"); $self->SetCallBacks(iq=>sub{ $self->callbackIQ(@_) }, presence=>sub{ $self->callbackPresence(@_) }, message=>sub{ $self->callbackMessage(@_) }, ); $self->SetPresenceCallBacks(subscribe=>sub{ $self->callbackPresenceSubscribe(@_) }, unsubscribe=>sub{ $self->callbackPresenceUnsubscribe(@_) }, subscribed=>sub{ $self->callbackPresenceSubscribed(@_) }, unsubscribed=>sub{ $self->callbackPresenceUnsubscribed(@_) }, ); $self->TLSInit(); $self->SASLInit(); $self->{DEBUG}->Log1("xmppCallbackInit: stop"); } ############################################################################## # # callbackMessage - default callback for packets. # ############################################################################## sub callbackMessage { my $self = shift; my $sid = shift; my $message = shift; my $type = "normal"; $type = $message->GetType() if $message->DefinedType(); $self->{DEBUG}->Log1("callbackMessage: type($type) sid($sid) "); if (exists($self->{CB}->{Mess}->{$type}) #&& (ref($self->{CB}->{Mess}->{$type}) =~ /CODE/) ) { &{$self->{CB}->{Mess}->{$type}}($sid,$message); } else { $self->{DEBUG}->Log1("callbackMessage: type($type) not code (ref($self->{CB}->{Mess}->{$type})) "); } } ############################################################################## # # callbackPresence - default callback for packets. # ############################################################################## sub callbackPresence { my $self = shift; my $sid = shift; my $presence = shift; my $type = "available"; $type = $presence->GetType() if $presence->DefinedType(); $self->{DEBUG}->Log1("callbackPresence: type($type) sid($sid) "); if (exists($self->{CB}->{Pres}->{$type}) # && (ref($self->{CB}->{Pres}->{$type}) =~ /CODE/) ) { &{$self->{CB}->{Pres}->{$type}}($sid,$presence); } } ############################################################################## # # callbackIQ - default callback for packets. # ############################################################################## sub callbackIQ { my $self = shift; my $sid = shift; my $iq = shift; $self->{DEBUG}->Log1("callbackIQ: sid($sid) iq($iq)"); return unless $iq->DefinedChild(); my $query = $iq->GetChild(); return unless defined($query); my $type = $iq->GetType(); my $ns = $query->GetXMLNS(); $self->{DEBUG}->Log1("callbackIQ: type($type) ns($ns)"); if (exists($self->{CB}->{IQns}->{$ns}) && (ref($self->{CB}->{IQns}->{$ns}) != 'HASH' ) ) { $self->{DEBUG}->Log1("callbackIQ: goto user function( $self->{CB}->{IQns}->{$ns} )"); &{$self->{CB}->{IQns}->{$ns}}($sid,$iq); } elsif (exists($self->{CB}->{IQns}->{$ns}->{$type}) # && (ref($self->{CB}->{IQns}->{$ns}->{$type}) =~ /CODE/) ) { $self->{DEBUG}->Log1("callbackIQ: goto user function( $self->{CB}->{IQns}->{$ns}->{$type} )"); &{$self->{CB}->{IQns}->{$ns}->{$type}}($sid,$iq); } } ############################################################################## # # callbackPresenceSubscribe - default callback for subscribe packets. # ############################################################################## sub callbackPresenceSubscribe { my $self = shift; my $sid = shift; my $presence = shift; my $reply = $presence->Reply(type=>"subscribed"); $self->Send($reply,1); $reply->SetType("subscribe"); $self->Send($reply,1); } ############################################################################## # # callbackPresenceUnsubscribe - default callback for unsubscribe packets. # ############################################################################## sub callbackPresenceUnsubscribe { my $self = shift; my $sid = shift; my $presence = shift; my $reply = $presence->Reply(type=>"unsubscribed"); $self->Send($reply,1); } ############################################################################## # # callbackPresenceSubscribed - default callback for subscribed packets. # ############################################################################## sub callbackPresenceSubscribed { my $self = shift; my $sid = shift; my $presence = shift; my $reply = $presence->Reply(type=>"subscribed"); $self->Send($reply,1); } ############################################################################## # # callbackPresenceUnsubscribed - default callback for unsubscribed packets. # ############################################################################## sub callbackPresenceUnsubscribed { my $self = shift; my $sid = shift; my $presence = shift; my $reply = $presence->Reply(type=>"unsubscribed"); $self->Send($reply,1); } ############################################################################## #+---------------------------------------------------------------------------- #| #| Stream functions #| #+---------------------------------------------------------------------------- ############################################################################## sub GetStreamID { my $self = shift; return $self->{SESSION}->{id}; } sub GetStreamFeature { my $self = shift; my $feature = shift; return $self->{STREAM}->GetStreamFeature($self->GetStreamID(),$feature); } sub RestartStream { my $self = shift; my $timeout = shift; $self->{SESSION} = $self->{STREAM}->OpenStream($self->GetStreamID(),$timeout); return $self->GetStreamID(); } ############################################################################## # # ConstXMLNS - Return the namespace from the constant string. # ############################################################################## sub ConstXMLNS { my $const = shift; return $XMLNS{$const}; } 1; Roster.pm000444000000000000 6167610602730024 17277 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::Roster; =head1 NAME Net::XMPP::Roster - XMPP Roster Object =head1 SYNOPSIS Net::XMPP::Roster is a module that provides a developer an easy interface to an XMPP roster. It provides high level functions to query, update, and manage a user's roster. =head1 DESCRIPTION The Roster object seeks to provide an easy to use API for interfacing with a user's roster. When you instantiate it, it automatically registers with the connection to receivce the correct packets so that it can track all roster updates, and presence packets. =head2 Basic Functions my $Client = new Net::XMPP::Client(...); my $Roster = new Net::XMPP::Roster(connection=>$Client); or my $Roster = $Client->Roster(); $Roster->clear(); if ($Roster->exists('bob@jabber.org')) { ... } if ($Roster->exists(Net::XMPP::JID)) { ... } if ($Roster->groupExists("Friends")) { ... } my @groups = $Roster->groups(); my @jids = $Roster->jids(); my @friends = $Roster->jids("group","Friends"); my @unfiled = $Roster->jids("nogroup"); if ($Roster->online('bob@jabber.org')) { ... } if ($Roster->online(Net::XMPP::JID)) { ... } my %hash = $Roster->query('bob@jabber.org'); my %hash = $Roster->query(Net::XMPP::JID); my $name = $Roster->query('bob@jabber.org',"name"); my $ask = $Roster->query(Net::XMPP::JID,"ask"); my $resource = $Roster->resource('bob@jabber.org'); my $resource = $Roster->resource(Net::XMPP::JID); my %hash = $Roster->resourceQuery('bob@jabber.org',"Home"); my %hash = $Roster->resourceQuery(Net::XMPP::JID,"Club"); my $show = $Roster->resourceQuery('bob@jabber.org',"Home","show"); my $status = $Roster->resourceQuery(Net::XMPP::JID,"Work","status"); my @resource = $Roster->resources('bob@jabber.org'); my @resource = $Roster->resources(Net::XMPP::JID); $Roster->resourceStore('bob@jabber.org',"Home","gpgkey",key); $Roster->resourceStore(Net::XMPP::JID,"logged on","2004/04/07 ..."); $Roster->store('bob@jabber.org',"avatar",avatar); $Roster->store(Net::XMPP::JID,"display_name","Bob"); =head2 Advanced Functions These functions are only needed if you want to manually control the Roster. $Roster->add('bob@jabber.org', name=>"Bob", groups=>["Friends"] ); $Roster->add(Net::XMPP::JID); $Roster->addResource('bob@jabber.org', "Home", show=>"dnd", status=>"Working" ); $Roster->addResource(Net::XMPP::JID,"Work"); $Roster->remove('bob@jabber.org'); $Roster->remove(Net::XMPP::JID); $Roster->removeResource('bob@jabber.org',"Home"); $Roster->removeResource(Net::XMPP::JID,"Work"); $Roster->handler(Net::XMPP::IQ); $Roster->handler(Net::XMPP::Presence); =head1 METHODS =head2 Basic Functions new(connection=>object) - This creates and initializes the Roster object. The connection object is required so that the Roster can interact with the main connection object. It needs to be an object that inherits from Net::XMPP::Connection. clear() - removes everything from the database. exists(jid) - return 1 if the JID exists in the database, undef otherwise. The jid can either be a string, or a Net::XMPP::JID object. groupExists(group) - return 1 if the group exists in the database, undef otherwise. groups() - returns a list of all of the roster groups. jids([type, - returns a list of all of the matching JIDs. The valid [group]]) types are: all - return all JIDs in the roster. (default) nogroup - return all JIDs not in a roster group. group - return all of the JIDs in the specified roster group. online(jid) - return 1 if the JID is online, undef otherwise. The jid can either be a string, or a Net::XMPP::JID object. query(jid, - return a hash representing all of the data in the [key]) DB for this JID. The jid can either be a string, or a Net::XMPP::JID object. If you specify a key, then only the value for that key is returned. resource(jid) - return the string representing the resource with the highest priority for the JID. The jid can either be a string, or a Net::XMPP::JID object. resourceQuery(jid, - return a hash representing all of the data resource, the DB for the resource for this JID. The [key]) jid can either be a string, or a Net::XMPP::JID object. If you specify a key, then only the value for that key is returned. resources(jid) - returns the list of resources for the JID in order of highest priority to lowest priority. The jid can either be a string, or a Net::XMPP::JID object. resourceStore(jid, - store the specified value in the DB under resource, the specified key for the resource for this key, JID. The jid can either be a string, or a value) Net::XMPP::JID object. store(jid, - store the specified value in the DB under the key, specified key for this JID. The jid can either value) be a string, or a Net::XMPP::JID object. =head2 Advanced Functions add(jid, - Manually adds the JID to the Roster with the ask=>string, specified roster item settings. This does not groups=>arrayref handle subscribing to other users, only name=>string, manipulating the Roster object. The jid subscription=>string) can either be a string or a Net::XMPP::JID. addResource(jid, - Manually add the resource to the JID in the resource, Roster with the specified presence settings. priority=>int, This does not handle subscribing to other show=>string, users, only manipulating the Roster object. status=>string) The jid can either be a string or a Net::XMPP::JID. remove(jid) - Removes all reference to the JID from the Roster object. The jid can either be a string or a Net::XMPP::JID. removeResource(jid, - Removes the resource from the jid in the resource) Roster object. The jid can either be a string or a Net::XMPP::JID. handler(packet) - Take either a Net::XMPP::IQ or Net::XMPP::Presence packet and parse them according to the rules of the Roster object. Note, that it will only waste CPU time if you pass in IQs or Presences that are not roster related. =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut use strict; use Carp; sub new { my $proto = shift; my $self = { }; my %args; while($#_ >= 0) { $args{ lc(pop(@_)) } = pop(@_); } if (!exists($args{connection}) || !$args{connection}->isa("Net::XMPP::Connection")) { croak("You must pass Net::XMPP::Roster a valid connection object."); } $self->{CONNECTION} = $args{connection}; bless($self, $proto); $self->init(); return $self; } ############################################################################## # # init - initialize the module to use the roster database # ############################################################################## sub init { my $self = shift; $self->{CONNECTION}-> SetXPathCallBacks('/iq[@type="result" or @type="set"]/query[@xmlns="jabber:iq:roster"]'=>sub{ $self->handler(@_) }); $self->{CONNECTION}-> SetXPathCallBacks('/presence'=>sub{ $self->handler(@_) }); } ############################################################################## # # add - adds the entry to the Roster DB. # ############################################################################## sub add { my $self = shift; my ($jid,%item) = @_; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); $self->{JIDS}->{$jid} = \%item; if (exists($item{groups})) { foreach my $group (@{$item{groups}}) { $self->{GROUPS}->{$group}->{$jid} = 1; } } } ############################################################################## # # addResource - adds the resource to the JID in the Roster DB. # ############################################################################## sub addResource { my $self = shift; my $jid = shift; my $resource = shift; my (%item) = @_; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); my $priority = $item{priority}; $priority = 0 unless defined($priority); $self->{CONNECTION}->{DEBUG}->Log3("Roster::addResource: add $jid/$resource with priority $priority to the DB"); my $loc = -1; $self->{JIDS}->{$jid}->{priorities}->{$priority} = [] unless exists($self->{JIDS}->{$jid}->{priorities}->{$priority}); foreach my $index (0..$#{$self->{JIDS}->{$jid}->{priorities}->{$priority}}) { $loc = $index if ($self->{JIDS}->{$jid}->{priorities}->{$priority}->[$index]->{resource} eq $resource); } $loc = $#{$self->{JIDS}->{$jid}->{priorities}->{$priority}} + 1 if ($loc == -1); $self->{JIDS}->{$jid}->{resources}->{$resource}->{priority} = $priority; $self->{JIDS}->{$jid}->{resources}->{$resource}->{status} = $item{status} if exists($item{status}); $self->{JIDS}->{$jid}->{resources}->{$resource}->{show} = $item{show} if exists($item{show}); $self->{JIDS}->{$jid}->{priorities}->{$priority}->[$loc]->{resource} = $resource; } ############################################################################### # # clear - delete all of the JIDs from the DB completely. # ############################################################################### sub clear { my $self = shift; $self->{CONNECTION}->{DEBUG}->Log3("Roster::clear: clearing the database"); foreach my $jid ($self->jids()) { $self->remove($jid); } $self->{CONNECTION}->{DEBUG}->Log3("Roster::clear: database is empty"); } ############################################################################## # # exists - allows you to query if the JID exists in the Roster DB. # ############################################################################## sub exists { my $self = shift; my ($jid) = @_; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); return unless exists($self->{JIDS}); return unless exists($self->{JIDS}->{$jid}); return 1; } sub fetch { my $self = shift; my %newroster = $self->{CONNECTION}->RosterGet(); $self->handleRoster(\%newroster); } ############################################################################## # # groupExists - allows you to query if the group exists in the Roster # DB. # ############################################################################## sub groupExists { my $self = shift; my ($group) = @_; return unless exists($self->{GROUPS}); return unless exists($self->{GROUPS}->{$group}); return 1; } ############################################################################## # # groups - returns a list of the current groups in your roster. # ############################################################################## sub groups { my $self = shift; return () unless exists($self->{GROUPS}); return () if (scalar(keys(%{$self->{GROUPS}})) == 0); return keys(%{$self->{GROUPS}}); } ############################################################################## # # handler - takes a packet and calls the correct handler. # ############################################################################## sub handler { my $self = shift; my $sid = shift; my $packet = shift; $self->handleIQ($packet) if ($packet->GetTag() eq "iq"); $self->handlePresence($packet) if ($packet->GetTag() eq "presence"); } ############################################################################## # # handleIQ - takes an iq packet that contains roster, parses it, and puts # the roster into the Roster DB. # ############################################################################## sub handleIQ { my $self = shift; my $iq = shift; print "handleIQ: iq(",$iq->GetXML(),")\n"; my $type = $iq->GetType(); return unless (($type eq "set") || ($type eq "result")); my %newroster = $self->{CONNECTION}->RosterParse($iq); $self->handleRoster(\%newroster); } sub handleRoster { my $self = shift; my $roster = shift; foreach my $jid (keys(%{$roster})) { $self->remove($jid); if ($roster->{$jid}->{subscription} ne "remove") { $self->add($jid, %{$roster->{$jid}}); } } } ############################################################################## # # handlePresence - takes a presence packet and groks the presence. # ############################################################################## sub handlePresence { my $self = shift; my $presence = shift; print "handlePresence: presence(",$presence->GetXML(),")\n"; my $type = $presence->GetType(); $type = "" unless defined($type); return unless (($type eq "") || ($type eq "available") || ($type eq "unavailable")); my $jid = $presence->GetFrom("jid"); my $resource = $jid->GetResource(); $resource = " " unless ($resource ne ""); $jid = $jid->GetJID(); $jid = "" unless defined($jid); return unless $self->exists($jid); #XXX if it doesn't exist... is it us? #XXX is this a presence based roster? $self->{CONNECTION}->{DEBUG}->Log3("Roster::PresenceDBParse: fromJID(",$presence->GetFrom(),") resource($resource) type($type)"); $self->{CONNECTION}->{DEBUG}->Log4("Roster::PresenceDBParse: xml(",$presence->GetXML(),")"); $self->removeResource($jid,$resource); if (($type eq "") || ($type eq "available")) { my %item; $item{priority} = $presence->GetPriority(); $item{priority} = 0 unless defined($item{priority}); $item{show} = $presence->GetShow(); $item{show} = "" unless defined($item{show}); $item{status} = $presence->GetStatus(); $item{status} = "" unless defined($item{status}); $self->addResource($jid,$resource,%item); } } ############################################################################## # # jids - returns a list of all of the JIDs in your roster. # ############################################################################## sub jids { my $self = shift; my $type = shift; my $group = shift; $type = "all" unless defined($type); my @jids; if (($type eq "all") || ($type eq "nogroup")) { return () unless exists($self->{JIDS}); foreach my $jid (keys(%{$self->{JIDS}})) { next if (($type eq "nogroup") && exists($self->{JIDS}->{$jid}->{groups}) && ($#{$self->{JIDS}->{$jid}->{groups}} > -1)); push(@jids,new Net::XMPP::JID($jid)); } } if ($type eq "group") { return () unless exists($self->{GROUPS}); if (defined($group) && $self->groupExists($group)) { foreach my $jid (keys(%{$self->{GROUPS}->{$group}})) { push(@jids,new Net::XMPP::JID($jid)); } } } return @jids; } ############################################################################### # # online - returns if the jid is online or not. # ############################################################################### sub online { my $self = shift; my $jid = shift; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); return unless $self->exists($jid); my @resources = $self->resources($jid); return ($#resources > -1); } ############################################################################## # # priority - return the highest priority for the jid, or for the specified # resource. # ############################################################################## sub priority { my $self = shift; my $jid = shift; my $resource = shift; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); if (defined($resource)) { return unless $self->resourceExists($jid,$resource); return unless exists($self->{JIDS}->{$jid}->{resources}->{$resource}->{priority}); return $self->{JIDS}->{$jid}->{resources}->{$resource}->{priority}; } return unless exists($self->{JIDS}->{$jid}->{priorities}); my @priorities = sort{ $b <=> $a } keys(%{$self->{JIDS}->{$jid}->{priorities}}); return $priorities[0]; } ############################################################################## # # query - allows you to get one of the pieces of info from the Roster DB. # ############################################################################## sub query { my $self = shift; my $jid = shift; my $key = shift; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); return unless $self->exists($jid); if (defined($key)) { return unless exists($self->{JIDS}->{$jid}->{$key}); return $self->{JIDS}->{$jid}->{$key}; } return %{$self->{JIDS}->{$jid}}; } ############################################################################## # # remove - removes the JID from the Roster DB. # ############################################################################## sub remove { my $self = shift; my $jid = shift; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); if ($self->exists($jid)) { $self->{CONNECTION}->{DEBUG}->Log3("Roster::remove: deleting $jid from the DB"); if (defined($self->query($jid,"groups"))) { foreach my $group (@{$self->query($jid,"groups")}) { delete($self->{GROUPS}->{$group}->{$jid}); delete($self->{GROUPS}->{$group}) if (scalar(keys(%{$self->{GROUPS}->{$group}})) == 0); delete($self->{GROUPS}) if (scalar(keys(%{$self->{GROUPS}})) == 0); } } delete($self->{JIDS}->{$jid}); delete($self->{JIDS}) if (scalar(keys(%{$self->{JIDS}})) == 0); } } ############################################################################## # # removeResource - removes the resource from the JID from the Roster DB. # ############################################################################## sub removeResource { my $self = shift; my $jid = shift; my $resource = shift; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); if ($self->resourceExists($jid,$resource)) { $self->{CONNECTION}->{DEBUG}->Log3("Roster::removeResource: remove $jid/$resource from the DB"); my $oldPriority = $self->priority($jid,$resource); $oldPriority = "" unless defined($oldPriority); if (exists($self->{JIDS}->{$jid}->{priorities}->{$oldPriority})) { my $loc = 0; foreach my $index (0..$#{$self->{JIDS}->{$jid}->{priorities}->{$oldPriority}}) { $loc = $index if ($self->{JIDS}->{$jid}->{priorities}->{$oldPriority}->[$index]->{resource} eq $resource); } splice(@{$self->{JIDS}->{$jid}->{priorities}->{$oldPriority}},$loc,1); delete($self->{JIDS}->{$jid}->{priorities}->{$oldPriority}) if (exists($self->{JIDS}->{$jid}->{priorities}->{$oldPriority}) && ($#{$self->{JIDS}->{$jid}->{priorities}->{$oldPriority}} == -1)); } delete($self->{JIDS}->{$jid}->{resources}->{$resource}); } } ############################################################################### # # resource - retrieve the resource with the highest priority. # ############################################################################### sub resource { my $self = shift; my $jid = shift; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); return unless $self->exists($jid); my $priority = $self->priority($jid); return unless defined($priority); return $self->{JIDS}->{$jid}->{priorities}->{$priority}->[0]->{resource}; } ############################################################################## # # resourceExists - check that the specified resource exists. # ############################################################################## sub resourceExists { my $self = shift; my $jid = shift; my $resource = shift; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); return unless $self->exists($jid); return unless exists($self->{JIDS}->{$jid}->{resources}); return unless exists($self->{JIDS}->{$jid}->{resources}->{$resource}); } ############################################################################## # # resourceQuery - allows you to get one of the pieces of info from the Roster # DB. # ############################################################################## sub resourceQuery { my $self = shift; my $jid = shift; my $resource = shift; my $key = shift; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); return unless $self->resourceExists($jid,$resource); if (defined($key)) { return unless exists($self->{JIDS}->{$jid}->{resources}->{$resource}->{$key}); return $self->{JIDS}->{$jid}->{resources}->{$resource}->{$key}; } return %{$self->{JIDS}->{$jid}->{resources}->{$resource};} } ############################################################################### # # resources - returns a list of the resources from highest priority to lowest. # ############################################################################### sub resources { my $self = shift; my $jid = shift; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); return () unless $self->exists($jid); my @resources; foreach my $priority (sort {$b cmp $a} keys(%{$self->{JIDS}->{$jid}->{priorities}})) { foreach my $index (0..$#{$self->{JIDS}->{$jid}->{priorities}->{$priority}}) { next if ($self->{JIDS}->{$jid}->{priorities}->{$priority}->[$index]->{resource} eq " "); push(@resources,$self->{JIDS}->{$jid}->{priorities}->{$priority}->[$index]->{resource}); } } return @resources; } ############################################################################## # # resourceStore - allows you to store anything on the item that you want to. # The only drawback is that when the item is removed, the data # is not kept. You must restore it in the DB. # ############################################################################## sub resourceStore { my $self = shift; my $jid = shift; my $resource = shift; my $key = shift; my $value = shift; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); return unless defined($key); return unless defined($value); return unless $self->resourceExists($jid,$resource); $self->{JIDS}->{$jid}->{resources}->{$resource}->{$key} = $value; } ############################################################################## # # store - allows you to store anything on the item that you want to. The # only drawback is that when the item is removed, the data is not # kept. You must restore it in the DB. # ############################################################################## sub store { my $self = shift; my $jid = shift; my $key = shift; my $value = shift; $jid = $jid->GetJID() if $jid->isa("Net::XMPP::JID"); return unless defined($key); return unless defined($value); return unless $self->exists($jid); $self->{JIDS}->{$jid}->{$key} = $value; } 1; Stanza.pm000444000000000000 12743210602730052 17273 0ustar00unknownunknown000000000000Net-XMPP-1.02/lib/Net/XMPP############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::XMPP::Stanza; =head1 NAME Net::XMPP::Stanza - XMPP Stanza Module =head1 SYNOPSIS Net::XMPP::Stanza is a private package that serves as a basis for all XMPP stanzas generated by Net::XMPP. =head1 DESCRIPTION This module is not meant to be used directly. You should be using either Net::XMPP::IQ, Net::XMPP::Message, Net::XMPP::Presence, or another package that inherits from Net::XMPP::Stanza. That said, this is where all of the namespaced methods are documented. The current supported namespaces are: =cut # NS_BEGIN =pod jabber:iq:auth jabber:iq:privacy jabber:iq:register jabber:iq:roster urn:ietf:params:xml:ns:xmpp-bind urn:ietf:params:xml:ns:xmpp-session =cut # NS_END =pod For more information on what these namespaces are for, visit http://www.jabber.org and browse the Jabber Programmers Guide. The following tables can be read as follows: ny:private:ns Name Type Get Set Remove Defined Add ========================== ======= === === ====== ======= === Foo scalar X X X X Bar child X Bars child X Test master X X Withing the my:private:ns namespace, there exists the functions: GetFoo(), SetFoo(), RemoveFoo(), DefinedFoo() AddBar() GetBars(), DefinedBars() GetTest(), SetMaster() Hopefully it should be obvious how this all works. If not feel free to contact me and I'll work on adding more documentation. =cut # DOC_BEGIN =head1 jabber:iq:auth Name Type Get Set Remove Defined Add ========================== ========= === === ====== ======= === Digest scalar X X X X Hash scalar X X X X Password scalar X X X X Resource scalar X X X X Sequence scalar X X X X Token scalar X X X X Username scalar X X X X Auth master X X =head1 jabber:iq:privacy Name Type Get Set Remove Defined Add ========================== ========= === === ====== ======= === Active scalar X X X X Default scalar X X X X List child X Lists child X X X Privacy master X X =head1 jabber:iq:privacy - item objects Name Type Get Set Remove Defined Add ========================== ========= === === ====== ======= === Action scalar X X X X IQ flag X X X X Message flag X X X X Order scalar X X X X PresenceIn flag X X X X PresenceOut flag X X X X Type scalar X X X X Value scalar X X X X Item master X X =head1 jabber:iq:privacy - list objects Name Type Get Set Remove Defined Add ========================== ========= === === ====== ======= === Name scalar X X X X Item child X Items child X X X List master X X =head1 jabber:iq:register Name Type Get Set Remove Defined Add ========================== ========= === === ====== ======= === Address scalar X X X X City scalar X X X X Date scalar X X X X Email scalar X X X X First scalar X X X X Instructions scalar X X X X Key scalar X X X X Last scalar X X X X Misc scalar X X X X Name scalar X X X X Nick scalar X X X X Password scalar X X X X Phone scalar X X X X Registered flag X X X X Remove flag X X X X State scalar X X X X Text scalar X X X X URL scalar X X X X Username scalar X X X X Zip scalar X X X X Register master X X =head1 jabber:iq:roster Name Type Get Set Remove Defined Add ========================== ========= === === ====== ======= === Item child X Items child X Roster master X X =head1 jabber:iq:roster - item objects Name Type Get Set Remove Defined Add ========================== ========= === === ====== ======= === Ask scalar X X X X Group array X X X X JID jid X X X X Name scalar X X X X Subscription scalar X X X X Item master X X =head1 urn:ietf:params:xml:ns:xmpp-bind Name Type Get Set Remove Defined Add ========================== ========= === === ====== ======= === JID jid X X X X Resource scalar X X X X Bind master X X =head1 urn:ietf:params:xml:ns:xmpp-session Name Type Get Set Remove Defined Add ========================== ========= === === ====== ======= === Session master X X =cut # DOC_END =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL. =cut use strict; use Carp; use Net::XMPP::Namespaces; use vars qw( $AUTOLOAD %FUNCTIONS $DEBUG ); $DEBUG = new Net::XMPP::Debug(usedefault=>1, header=>"XMPP"); # XXX need to look at evals and $@ sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = { }; bless($self, $proto); $self->{DEBUGHEADER} = "Stanza"; $self->{TAG} = "__netxmpp__:unknown:tag"; $self->{FUNCS} = \%FUNCTIONS; my $result = $self->_init(@_); return $result if defined($result); return $self; } sub _init { my $self = shift; $self->{CHILDREN} = []; if ("@_" ne ("")) { if ($_[0]->isa("Net::XMPP::Stanza")) { return $_[0]; } elsif (ref($_[0]) eq "") { $self->{TAG} = shift; $self->{TREE} = new XML::Stream::Node($self->{TAG}); } else { $self->{TREE} = shift; $self->{TAG} = $self->{TREE}->get_tag(); $self->_parse_xmlns(); $self->_parse_tree(); } } else { $self->{TREE} = new XML::Stream::Node($self->{TAG}); } return; } $FUNCTIONS{XMLNS}->{path} = '@xmlns'; $FUNCTIONS{Child}->{type} = 'child'; $FUNCTIONS{Child}->{path} = '*[@xmlns]'; $FUNCTIONS{Child}->{child} = {}; ############################################################################## # # debug - prints out the XML::Parser Tree in a readable format for debugging # ############################################################################## sub debug { my $self = shift; print "debug ",$self,":\n"; &Net::XMPP::printData("debug: \$self->{CHILDREN}->",$self->{CHILDREN}); } ############################################################################## #+---------------------------------------------------------------------------- #| #| Public Methods #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # GetXML - Returns a string that represents the packet. # ############################################################################## sub GetXML { my $self = shift; return $self->GetTree()->GetXML(); } ############################################################################## # # GetTag - Returns the root tag of the object. # ############################################################################## sub GetTag { my $self = shift; return $self->{TAG}; } ############################################################################## # # GetTree - Returns an XML::Stream::Node that contains the full tree including # Query, and X children. # ############################################################################## sub GetTree { my $self = shift; my $keepXMLNS = shift; $keepXMLNS = 0 unless defined($keepXMLNS); my $node = $self->{TREE}->copy(); $node->remove_attrib("xmlns") if (exists($self->{SKIPXMLNS}) && ($keepXMLNS == 0)); foreach my $child (@{$self->{CHILDREN}}) { my $child_tree = $child->GetTree($keepXMLNS); $node->add_child($child_tree); } my $remove_ns = 0; if (defined($node->get_attrib("xmlns")) && ($keepXMLNS == 0)) { $remove_ns = 1 if ($self->_check_skip_xmlns($node->get_attrib("xmlns"))); } $node->remove_attrib("xmlns") if ($remove_ns == 1); $node->add_raw_xml(@{$self->{RAWXML}}) if (exists($self->{RAWXML}) && ($#{$self->{RAWXML}} > -1)); return $node; } ############################################################################## # # NewChild - calls AddChild to create a new Net::XMPP::Stanza object, sets the # xmlns and returns a pointer to the new object. # ############################################################################## sub NewChild { my $self = shift; my $xmlns = shift; my $tag = shift; return unless exists($Net::XMPP::Namespaces::NS{$xmlns}); if (!defined($tag)) { $tag = "x"; $tag = $Net::XMPP::Namespaces::NS{$xmlns}->{tag} if exists($Net::XMPP::Namespaces::NS{$xmlns}); } my $node = new XML::Stream::Node($tag); $node->put_attrib(xmlns=>$xmlns); return $self->AddChild($node); } ############################################################################## # # AddChild - creates a new Net::XMPP::packet object, pushes it on the child # list, and returns a pointer to the new object. This is a # private helper function. # ############################################################################## sub AddChild { my $self = shift; my $node = shift; my $packet = $self->_new_packet($node); push(@{$self->{CHILDREN}},$packet); return $packet; } ############################################################################## # # RemoveChild - removes all xtags that have the specified namespace. # ############################################################################## sub RemoveChild { my $self = shift; my $xmlns = shift; foreach my $index (reverse(0..$#{$self->{CHILDREN}})) { splice(@{$self->{CHILDREN}},$index,1) if (!defined($xmlns) || ($xmlns eq "") || ($self->{CHILDREN}->[$index]->GetXMLNS() eq $xmlns)); } } ############################################################################## # # NewFirstChild - calls AddFirstChild to create a new Net::XMPP::Stanza # object, sets the xmlns and returns a pointer to the new # object. # ############################################################################## sub NewFirstChild { my $self = shift; my $xmlns = shift; my $tag = shift; return unless exists($Net::XMPP::Namespaces::NS{$xmlns}); if (!defined($tag)) { $tag = "x"; $tag = $Net::XMPP::Namespaces::NS{$xmlns}->{tag} if exists($Net::XMPP::Namespaces::NS{$xmlns}); } my $node = new XML::Stream::Node($tag); $node->put_attrib(xmlns=>$xmlns); return $self->AddFirstChild($node); } ############################################################################## # # AddFirstChild - creates a new Net::XMPP::packet object, puts it on the child # list in the front, and returns a pointer to the new object. # This is a private helper function. # ############################################################################## sub AddFirstChild { my $self = shift; my $node = shift; my $packet = $self->_new_packet($node); unshift(@{$self->{CHILDREN}},$packet); return $packet; } ############################################################################## # # RemoveFirstChild - removes all xtags that have the specified namespace. # ############################################################################## sub RemoveFirstChild { my $self = shift; shift(@{$self->{CHILDREN}}); } ############################################################################## # # InsertRawXML - puts the specified string onto the list for raw XML to be # included in the packet. # ############################################################################## sub InsertRawXML { my $self = shift; my(@rawxml) = @_; if (!exists($self->{RAWXML})) { $self->{RAWXML} = []; } push(@{$self->{RAWXML}},@rawxml); } ############################################################################## # # ClearRawXML - removes all raw XML from the packet. # ############################################################################## sub ClearRawXML { my $self = shift; $self->{RAWXML} = []; } ############################################################################## #+---------------------------------------------------------------------------- #| #| AutoLoad methods #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # AutoLoad - This function is a central location for handling all of the # AUTOLOADS for all of the sub modules. # ############################################################################## sub AUTOLOAD { my $self = shift; return if ($AUTOLOAD =~ /::DESTROY$/); my ($package) = ($AUTOLOAD =~ /^(.*)::/); $AUTOLOAD =~ s/^.*:://; my ($call,$var) = ($AUTOLOAD =~ /^(Add|Get|Set|Remove|Defined)(.*)$/); $call = "" unless defined($call); $var = "" unless defined($var); #$self->_debug("AUTOLOAD: self($self) AUTOLOAD($AUTOLOAD) package($package)"); #$self->_debug("AUTOLOAD: tag($self->{TAG}) call($call) var($var) args(",join(",",@_),")"); #------------------------------------------------------------------------- # Pick off calls for top level tags , , and #------------------------------------------------------------------------- my @xmlns = $self->{TREE}->XPath('@xmlns'); my $XPathArgs = $self->_xpath_AUTOLOAD($package,$call,$var,$xmlns[0]); return $self->_xpath($call,@{$XPathArgs},@_) if defined($XPathArgs); #------------------------------------------------------------------------- # We don't know what this function is... Hand it off to Missing Persons... #------------------------------------------------------------------------- $self->_missing_function($AUTOLOAD); } ############################################################################## # # _xpath_AUTOLOAD - This function is a helper function for the main AutoLoad # function to help cut down on repeating code. # ############################################################################## sub _xpath_AUTOLOAD { my $self = shift; my $package = shift; my $call = shift; my $var = shift; my $xmlns = shift; $self->_debug("_xpath_AUTOLOAD: self($self) package($package) call($call) var($var)"); $self->_debug("_xpath_AUTOLOAD: xmlns($xmlns)") if defined($xmlns); #------------------------------------------------------------------------- # First thing, figure out which group of functions we are going to be # working with. FUNCTIONS, or NS{$xmlns}->{xpath}... #------------------------------------------------------------------------- my $funcs = $self->_xpath_funcs($package,$call,$var,$xmlns); return unless defined($funcs); my @setFuncs = grep { $_ ne $var } keys(%{$funcs}); #$self->_debug("_xpath_AUTOLOAD: setFuncs(",join(",",@setFuncs),")"); my $type = (exists($funcs->{$var}->{type}) ? $funcs->{$var}->{type} : "scalar" ); my $path = (exists($funcs->{$var}->{path}) ? $funcs->{$var}->{path} : "" ); $path = "*" if ($type eq "raw"); my $child = ""; #------------------------------------------------------------------------- # When this is a master function... change the above variables... #------------------------------------------------------------------------- if(($type eq "master") || ((ref($type) eq "ARRAY") && ($type->[0] eq "master"))) { if ($call eq "Get") { my @newSetFuncs; foreach my $func (@setFuncs) { my $funcType = ( exists($funcs->{$func}->{type}) ? $funcs->{$func}->{type} : undef ); push(@newSetFuncs,$func) if (!defined($funcType) || ($funcType eq "scalar") || ($funcType eq "jid") || ($funcType eq "array") || ($funcType eq "flag") || ($funcType eq "timestamp") || (ref($funcType) eq "ARRAY")); } $child = \@newSetFuncs; } else { $child = \@setFuncs; } } #------------------------------------------------------------------------- # When this is a child based function... change the above variables... #------------------------------------------------------------------------- elsif (exists($funcs->{$var}->{child})) { $child = $funcs->{$var}->{child}; #$self->_debug("_xpath_AUTOLOAD: child($child)"); if (exists($child->{ns})) { my $addXMLNS = $child->{ns}; my $addFuncs = $Net::XMPP::Namespaces::NS{$addXMLNS}->{xpath}; my @calls = grep { exists($addFuncs->{$_}->{type}) && ($addFuncs->{$_}->{type} eq "master") } keys(%{$addFuncs}); if ($#calls > 0) { print STDERR "Warning: I cannot serve two masters.\n"; } $child->{master} = $calls[0]; } } #------------------------------------------------------------------------- # Return the arguments for the xpath function #------------------------------------------------------------------------- #$self->_debug("_xpath_AUTOLOAD: return($type,$path,$child);"); return [$type,$path,$child]; } ############################################################################## # # _xpath_funcs - Return the list of functions either from the FUNCTIONS hash # or from Net::XMPP::Namespaces::NS. # ############################################################################## sub _xpath_funcs { my $self = shift; my $package = shift; my $call = shift; my $var = shift; my $xmlns = shift; my $funcs; my $coreFuncs = $self->{FUNCS}; #eval "\$coreFuncs = \\%".$package."::FUNCTIONS"; $coreFuncs = {} unless defined($coreFuncs); my $nsFuncs = {}; $nsFuncs = $Net::XMPP::Namespaces::NS{$xmlns}->{xpath} if (defined($xmlns) && exists($Net::XMPP::Namespaces::NS{$xmlns})); foreach my $set ($coreFuncs,$nsFuncs) { if (exists($set->{$var})) { my $type = (exists($set->{$var}->{type}) ? $set->{$var}->{type} : "scalar" ); my @calls = ('Get','Set','Defined','Remove'); @calls = ('Get','Set') if ($type eq "master"); @calls = ('Get','Defined','Remove') if ($type eq "child"); @calls = @{$set->{$var}->{calls}} if exists($set->{$var}->{calls}); foreach my $callName (@calls) { if ($callName eq $call) { $funcs = $set; last; } } } } #------------------------------------------------------------------------- # If we didn't find any functions to return, Return failure. #------------------------------------------------------------------------- if (!defined($funcs)) { #$self->_debug("_xpath_AUTOLOAD: no funcs found"); return; } return $funcs; } ############################################################################## # # _xpath - given a type it calls the appropriate _xpath_* function below # ############################################################################## sub _xpath { my $self = shift; my $call = shift; #$self->_debug("_xpath: call($call) args(",join(",",@_),")"); if ($call eq "Get") { return $self->_xpath_get(@_) ; } elsif ($call eq "Set") { return $self->_xpath_set(@_); } elsif ($call eq "Defined") { return $self->_xpath_defined(@_); } elsif ($call eq "Add") { return $self->_xpath_add(@_); } elsif ($call eq "Remove") { return $self->_xpath_remove(@_); } } ############################################################################## # # _xpath_get - returns the value stored in the node # ############################################################################## sub _xpath_get { my $self = shift; my $type = shift; my $xpath = shift; my $childtype = shift; my ($arg0) = shift; #$self->_debug("_xpath_get: self($self) type($type) xpath($xpath) childtype($childtype)"); #$self->{TREE}->debug(); my $subType; ($type,$subType) = $self->_xpath_resolve_types($type); #------------------------------------------------------------------------- # type == master #------------------------------------------------------------------------- if ($type eq "master") { my %fields; foreach my $func (sort {$a cmp $b} @{$childtype}) { my $defined; eval "\$defined = \$self->Defined$func();"; if ($defined) { my @values; eval "\@values = \$self->Get$func();"; if ($#values > 0) { $fields{lc($func)} = \@values; } else { $fields{lc($func)} = $values[0]; } } } return %fields; } #------------------------------------------------------------------------- # type == node #------------------------------------------------------------------------- # XXX Remove this if there are no problems #if ($type eq "node") #{ #$self->_debug("_xpath_get: node: xmlns($arg0)") if defined($arg0); #my @results; #foreach my $child (@{$self->{CHILDREN}}) #{ #$self->_debug("_xpath_get: node: child($child)"); #$self->_debug("_xpath_get: node: childXML(",$child->GetXML(),")"); #push(@results,$child) # if (!defined($arg0) || # ($arg0 eq "") || # ($child->GetTree(1)->get_attrib("xmlns") eq $arg0)); #} #return $results[$childtype->{child_index}] if exists($childtype->{child_index}); #return @results if (wantarray); #return $results[0]; #} #------------------------------------------------------------------------- # The rest actually call the XPath, so call it. #------------------------------------------------------------------------- my @nodes = $self->{TREE}->XPath($xpath); #------------------------------------------------------------------------- # type == scalar or timestamp #------------------------------------------------------------------------- if (($type eq "scalar") || ($type eq "timestamp")) { return "" if ($#nodes == -1); return $nodes[0]; } #------------------------------------------------------------------------- # type == jid #------------------------------------------------------------------------- if ($type eq "jid") { return if ($#nodes == -1); return $self->_new_jid($nodes[0]) if (defined($arg0) && ($arg0 eq "jid")); return $nodes[0]; } #------------------------------------------------------------------------- # type == flag #------------------------------------------------------------------------- if ($type eq "flag") { return $#nodes > -1; } #------------------------------------------------------------------------- # type == array #------------------------------------------------------------------------- if ($type eq "array") { return @nodes if (wantarray); return $nodes[0]; } #------------------------------------------------------------------------- # type == raw #------------------------------------------------------------------------- if ($type eq "raw") { my $rawXML = ""; return join("",@{$self->{RAWXML}}) if ($#{$self->{RAWXML}} > -1); foreach my $node (@nodes) { $rawXML .= $node->GetXML(); } return $rawXML; } #------------------------------------------------------------------------- # type == child #------------------------------------------------------------------------- if (($type eq "child") || ($type eq "children") || ($type eq "node")) { my $xmlns = $arg0; $xmlns = $childtype->{ns} if exists($childtype->{ns}); #$self->_debug("_xpath_get: children: xmlns($xmlns)"); my @results; foreach my $child (@{$self->{CHILDREN}}) { push(@results, $child) if (!defined($xmlns) || ($xmlns eq "") || ($child->GetTree(1)->get_attrib("xmlns") eq $xmlns)); } foreach my $node (@nodes) { $node->put_attrib(xmlns=>$xmlns) unless defined($node->get_attrib("xmlns")); my $result = $self->AddChild($node); $self->{TREE}->remove_child($node); push(@results,$result) if (!defined($xmlns) || ($xmlns eq "") || ($node->get_attrib("xmlns") eq $xmlns)); } #$self->_debug("_xpath_get: children: ",join(",",@results)); return $results[$childtype->{child_index}] if exists($childtype->{child_index}); return @results if (wantarray); return $results[0]; } } ############################################################################## # # _xpath_set - makes the XML tree such that the value was set. # ############################################################################## sub _xpath_set { my $self = shift; my $type = shift; my $xpath = shift; my $childtype = shift; #$self->_debug("_xpath_set: self($self) type($type) xpath($xpath) childtype($childtype)"); my $subType; ($type,$subType) = $self->_xpath_resolve_types($type); my $node = $self->{TREE}; #$self->_debug("_xpath_set: node($node)"); #------------------------------------------------------------------------- # When the type is master, the rest of the args are in hash form #------------------------------------------------------------------------- if ($type eq "master") { #$self->_debug("_xpath_set: master: funcs(",join(",",@{$childtype}),")"); my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } #$self->_debug("_xpath_set: args(",%args,")"); foreach my $func (sort {$a cmp $b} @{$childtype}) { #$self->_debug("_xpath_set: func($func)"); if (exists($args{lc($func)})) { #$self->_debug("_xpath_set: \$self->Set$func(\$args{lc(\$func)});"); eval "\$self->Set$func(\$args{lc(\$func)});"; } elsif ($subType eq "all") { #$self->_debug("_xpath_set: \$self->Set$func();"); eval "\$self->Set$func();"; } } return; } #------------------------------------------------------------------------- # When the type is not master, there can be only one argument. #------------------------------------------------------------------------- my $value = shift; if ($type eq "raw") { $self->ClearRawXML(); $self->InsertRawXML($value); return; } #------------------------------------------------------------------------- # Hook to support special cases. You can register the specials with # the module and they will ba called based on match. #------------------------------------------------------------------------- if (($subType ne "") && exists($self->{CUSTOMSET}->{$subType})) { #$self->_debug("_xpath_set: custom: subType($subType)"); #$self->_debug("_xpath_set: custom: value($value)") if defined($value); $value = &{$self->{CUSTOMSET}->{$subType}}($self,$value); } if ($type eq "timestamp") { $value = "" unless defined($value); if ($value eq "") { $value = &Net::XMPP::GetTimeStamp("utc","","stamp"); } } #$self->_debug("_xpath_set: value($value)") unless !defined($value); #------------------------------------------------------------------------- # Now that we have resolved the value, we put it into an array so that we # can support array refs by referring to the values as an array. #------------------------------------------------------------------------- my @values; push(@values,$value); if ($type eq "array") { if (ref($value) eq "ARRAY") { @values = @{$value}; } } #$self->_debug("_xpath_set: values(",join(",",@values),")") unless !defined($value); #------------------------------------------------------------------------- # And now, for each value... #------------------------------------------------------------------------- foreach my $val (@values) { #$self->_debug("_xpath_set: val($val)") unless !defined($val); #$self->_debug("_xpath_set: type($type)"); next unless (defined($val) || ($type eq "flag")); if ((ref($val) ne "") && ($val->isa("Net::XMPP::JID"))) { $val = $val->GetJID("full"); } my $path = $xpath; #$self->_debug("_xpath_set: val($val)") unless !defined($val); #$self->_debug("_xpath_set: path($path)"); my $childPath = ""; while(($path !~ /^\/?\@/) && ($path !~ /^\/?text\(\)/)) { #$self->_debug("_xpath_set: Multi-level!!!!"); my ($child) = ($path =~ /^\/?([^\/]+)/); $path =~ s/^\/?[^\/]+//; #$self->_debug("_xpath_set: path($path)"); #$self->_debug("_xpath_set: childPath($childPath)"); if (($type eq "scalar") || ($type eq "jid") || ($type eq "timestamp")) { my $tmpPath = $child; $tmpPath = "$childPath/$child" if ($childPath ne ""); my @nodes = $self->{TREE}->XPath("$tmpPath"); #$self->_debug("_xpath_set: \$#nodes($#nodes)"); if ($#nodes == -1) { if ($childPath eq "") { $node = $self->{TREE}->add_child($child); } else { my $tree = $self->{TREE}->XPath("$childPath"); $node = $tree->add_child($child); } } else { $node = $nodes[0]; } } if ($type eq "array") { $node = $self->{TREE}->add_child($child); } if ($type eq "flag") { $node = $self->{TREE}->add_child($child); return; } $childPath .= "/" unless ($childPath eq ""); $childPath .= $child; } my ($piece) = ($path =~ /^\/?([^\/]+)/); #$self->_debug("_xpath_set: piece($piece)"); if ($piece =~ /^\@(.+)$/) { $node->put_attrib($1=>$val); } elsif ($piece eq "text()") { $node->remove_cdata(); $node->add_cdata($val); } } } ############################################################################## # # _xpath_defined - returns true if there is data for the requested item, false # otherwise. # ############################################################################## sub _xpath_defined { my $self = shift; my $type = shift; my $xpath = shift; my $childtype = shift; my $ns = shift; $self->_debug("_xpath_defined: self($self) type($type) xpath($xpath) childtype($childtype)"); $self->_debug("_xpath_defined: ns($ns)") if defined($ns); $self->_debug("_xpath_defined: xml(",$self->{TREE}->GetXML(),")"); my $subType; ($type,$subType) = $self->_xpath_resolve_types($type); $self->_debug("_xpath_defined: type($type) subType($subType) "); if ($type eq "raw") { if ($#{$self->{RAWXML}} > -1) { return 1; } } my @nodes = $self->{TREE}->XPath($xpath); # If the $ns is defined, then the presence of nodes does not mean # we're defined, we have to check them. my $defined = ( @nodes > 0 && !defined($ns) ); $self->_debug("_xpath_defined: nodes(",join(",",@nodes),")"); if (!@nodes && (($type eq "child") || ($type eq "children") || ($type eq "node"))) { if ((ref($childtype) eq "HASH") && exists($childtype->{ns})) { $ns = $childtype->{ns}; } } $self->_debug("_xpath_defined: ns(".$ns.") defined(".$defined.")") if defined($ns); foreach my $packet (@{$self->{CHILDREN}}) { $self->_debug("_xpath_defined: packet->GetXMLNS ",$packet->GetXMLNS()); if (defined($ns) && ($packet->GetXMLNS() eq $ns)) { $defined = 1; last; } # if we have children, and that's all we're looking for, then by golly # we're done. elsif ( !defined($ns) && $type =~ /child/ ) { $defined = 1; last; } } $self->_debug("_xpath_defined: defined($defined)"); return $defined; } ############################################################################## # # _xpath_add - returns the value stored in the node # ############################################################################## sub _xpath_add { my $self = shift; my $type = shift; my $xpath = shift; my $childtype = shift; my $xmlns = $childtype->{ns}; my $master = $childtype->{master}; #$self->_debug("_xpath_add: self($self) type($type) xpath($xpath) childtype($childtype)"); #$self->_debug("_xpath_add: xmlns($xmlns) master($master)"); my $tag = $xpath; if (exists($childtype->{specify_name})) { if (($#_ > -1) && (($#_/2) =~ /^\d+$/)) { $tag = shift; } else { $tag = $childtype->{tag}; } } my $node = new XML::Stream::Node($tag); $node->put_attrib(xmlns=>$xmlns); my $obj = $self->AddChild($node); eval "\$obj->Set${master}(\@_);" if defined($master); $obj->_skip_xmlns() if exists($childtype->{skip_xmlns}); return $obj; } ############################################################################## # # _xpath_remove - remove the specified thing from the data (I know it's vague.) # ############################################################################## sub _xpath_remove { my $self = shift; my $type = shift; my $xpath = shift; my $childtype = shift; #$self->_debug("_xpath_remove: self($self) type($type) xpath($xpath) childtype($childtype)"); my $subType; ($type,$subType) = $self->_xpath_resolve_types($type); my $nodePath = $xpath; $nodePath =~ s/\/?\@\S+$//; $nodePath =~ s/\/text\(\)$//; #$self->_debug("_xpath_remove: xpath($xpath) nodePath($nodePath)"); my @nodes; @nodes = $self->{TREE}->XPath($nodePath) if ($nodePath ne ""); #$self->_debug("_xpath_remove: nodes($#nodes)"); if ($xpath =~ /\@(\S+)/) { my $attrib = $1; #$self->_debug("_xpath_remove: attrib($attrib)"); if ($nodePath eq "") { $self->{TREE}->remove_attrib($attrib); } else { foreach my $node (@nodes) { $node->remove_attrib($attrib); } } return; } foreach my $node (@nodes) { #$self->_debug("_xpath_remove: node GetXML(".$node->GetXML().")"); $self->{TREE}->remove_child($node); } if ($type eq "child") { my @keep; foreach my $child (@{$self->{CHILDREN}}) { #$self->_debug("_xpath_remove: check(".$child->GetXML().")"); next if ($child->GetXMLNS() eq $childtype->{ns}); #$self->_debug("_xpath_remove: keep(".$child->GetXML().")"); push(@keep,$child); } $self->{CHILDREN} = \@keep; } } ############################################################################## # # _xpath_resolve_types - Resolve the type and subType into the correct values. # ############################################################################## sub _xpath_resolve_types { my $self = shift; my $type = shift; my $subType = ""; if (ref($type) eq "ARRAY") { if ($type->[0] eq "special") { $subType = $type->[1]; $type = "scalar"; } elsif ($type->[0] eq "master") { $subType = $type->[1]; $type = "master"; } } #$self->_debug("_xpath_resolve_types: type($type) subtype($subType)"); return ($type,$subType); } ############################################################################## # # _parse_xmlns - anything that uses the namespace method must first kow what # the xmlns of this thing is... So here's a function to do # just that. # ############################################################################## sub _parse_xmlns { my $self = shift; $self->SetXMLNS($self->{TREE}->get_attrib("xmlns")) if defined($self->{TREE}->get_attrib("xmlns")); } ############################################################################## # # _parse_tree - run through the XML::Stream::Node and pull any child nodes # out that we recognize and create objects for them. # ############################################################################## sub _parse_tree { my $self = shift; my @xTrees = $self->{TREE}->XPath('*[@xmlns]'); if ($#xTrees > -1) { foreach my $xTree (@xTrees) { if( exists($Net::XMPP::Namespaces::NS{$xTrees[0]->get_attrib("xmlns")})) { $self->AddChild($xTree); $self->{TREE}->remove_child($xTree); } } } } ############################################################################## #+---------------------------------------------------------------------------- #| #| Private Methods #| #+---------------------------------------------------------------------------- ############################################################################## sub _check_skip_xmlns { my $self = shift; my $xmlns = shift; foreach my $skipns (keys(%Net::XMPP::Namespaces::SKIPNS)) { return 1 if ($xmlns =~ /^$skipns/); } return 0; } ############################################################################## # # _debug - helper function for printing debug messages using Net::XMPP::Debug # ############################################################################## sub _debug { my $self = shift; return $DEBUG->Log99($self->{DEBUGHEADER},": ",@_); } ############################################################################## # # _missing_function - send an error if the function is missing. # ############################################################################## sub _missing_function { my ($parent,$function) = @_; croak("Undefined function $function in package ".ref($parent)); } ############################################################################## # # _new_jid - create a new JID object. # ############################################################################## sub _new_jid { my $self = shift; return new Net::XMPP::JID(@_); } ############################################################################## # # _new_packet - create a new Stanza object. # ############################################################################## sub _new_packet { my $self = shift; return new Net::XMPP::Stanza(@_); } ############################################################################## # # _skip_xmlns - in the GetTree function, cause the xmlns attribute to be # removed for a node that has this set. # ############################################################################## sub _skip_xmlns { my $self = shift; $self->{SKIPXMLNS} = 1; } 1; t000777000000000000 010603223625 13462 5ustar00unknownunknown000000000000Net-XMPP-1.021_load.t000444000000000000 11410573261145 15120 0ustar00unknownunknown000000000000Net-XMPP-1.02/tuse lib "t/lib"; use Test::More tests=>1; BEGIN{ use_ok( "Net::XMPP" ); } 2_client_jabberd1.4.t000444000000000000 553510573261145 17410 0ustar00unknownunknown000000000000Net-XMPP-1.02/tuse lib "t/lib"; use Test::More tests=>5; BEGIN{ use_ok( "Net::XMPP" ); } my $Client; my $connected = 0; my $server = "obelisk.net"; my $port = 5222; my $username = "test-netjabber"; my $password = "test"; my $resource = $$.time.qx(hostname); chomp($resource); ############################################################################### # # Make sure you can ever connect to the server. If we cannot then we should # skip the rest of the tests because they will fail. # ############################################################################### SKIP: { my $sock = IO::Socket::INET->new(PeerAddr=>"$server:$port"); skip "Cannot open connection (maybe a firewall?)",4 unless defined($sock); $sock->close(); $Client = new Net::XMPP::Client(); $Client->SetCallBacks(onconnect => \&onConnect, onauth => \&onAuth, message => \&onMessage, ); $Client->Execute(username=>$username, password=>$password, resource=>$resource, hostname=>$server, port=>$port, register=>1, connectsleep=>0, connectattempts=>1, ); #-------------------------------------------------------------------------- # If all went well, we should never get here. #-------------------------------------------------------------------------- ok(0,"Connected") unless $connected; ok(0,"Authenticated"); ok(0,"Subject"); ok(0,"Body"); } ############################################################################### # # onConnect - when we establish an initial connection to the server run the # following # ############################################################################### sub onConnect { $connected = 1; ok(1, "Connected"); } ############################################################################### # # onAuth - when we have successfully authenticated with the server send a # test message to ourselves. # ############################################################################### sub onAuth { $Client->MessageSend(to=>$username."@".$server."/".$resource, subject=>"test", body=>"This is a test."); ok(1, "Authenticated"); } ############################################################################### # # onMessage - when we get a message, check that the contents match what we sent # above. # ############################################################################### sub onMessage { my $sid = shift; my $message = shift; is( $message->GetSubject(), "test", "Subject" ); is( $message->GetBody(), "This is a test.", "Body" ); $Client->Disconnect(); exit(0); } 3_client_jabberd2.t000444000000000000 553510573261145 17250 0ustar00unknownunknown000000000000Net-XMPP-1.02/tuse lib "t/lib"; use Test::More tests=>5; BEGIN{ use_ok( "Net::XMPP" ); } my $Client; my $connected = 0; my $server = "obelisk.net"; my $port = 5225; my $username = "test-netjabber"; my $password = "test"; my $resource = $$.time.qx(hostname); chomp($resource); ############################################################################### # # Make sure you can ever connect to the server. If we cannot then we should # skip the rest of the tests because they will fail. # ############################################################################### SKIP: { my $sock = IO::Socket::INET->new(PeerAddr=>"$server:$port"); skip "Cannot open connection (maybe a firewall?)",4 unless defined($sock); $sock->close(); $Client = new Net::XMPP::Client(); $Client->SetCallBacks(onconnect => \&onConnect, onauth => \&onAuth, message => \&onMessage, ); $Client->Execute(username=>$username, password=>$password, resource=>$resource, hostname=>$server, port=>$port, register=>1, connectsleep=>0, connectattempts=>1, ); #-------------------------------------------------------------------------- # If all went well, we should never get here. #-------------------------------------------------------------------------- ok(0,"Connected") unless $connected; ok(0,"Authenticated"); ok(0,"Subject"); ok(0,"Body"); } ############################################################################### # # onConnect - when we establish an initial connection to the server run the # following # ############################################################################### sub onConnect { $connected = 1; ok(1, "Connected"); } ############################################################################### # # onAuth - when we have successfully authenticated with the server send a # test message to ourselves. # ############################################################################### sub onAuth { $Client->MessageSend(to=>$username."@".$server."/".$resource, subject=>"test", body=>"This is a test."); ok(1, "Authenticated"); } ############################################################################### # # onMessage - when we get a message, check that the contents match what we sent # above. # ############################################################################### sub onMessage { my $sid = shift; my $message = shift; is( $message->GetSubject(), "test", "Subject" ); is( $message->GetBody(), "This is a test.", "Body" ); $Client->Disconnect(); exit(0); } get_time_stamp.test000444000000000000 1210610602017045 17531 0ustar00unknownunknown000000000000Net-XMPP-1.02/t# OK I give up! # This test is disabled because it won't run on windows due to a bug in # XML::Stream # It should fail on Net::XMPP 1.0.1 and earlier # and is the primary reason for bothering to release 1.0.2 use Test::More tests=>25; #use Data::Dump qw(pp); use XML::Stream qw(Tree); BEGIN{ use_ok( "Net::XMPP" ); } my $debug_level = 100; my $debug = new Net::XMPP::Debug(setdefault=>1, level=>$debug_level, file=>"stdout", header=>"test", ); require "t/mytestlib.pl"; my $message_node = new XML::Stream::Node("message"); ok( defined($message_node), "new()"); isa_ok( $message_node, "XML::Stream::Node" ); $message_node->put_attrib(to=>"jer\@jabber.org", from=>"reatmon\@jabber.org", type=>'groupchat', 'xml:lang'=>'en'); my $body_node = $message_node->add_child("body"); $body_node->add_cdata("body"); my $html_node = $message_node->add_child("html"); $html_node->put_attrib(xmlns=>"http://jabber.org/protocol/xhtml-im"); my $html_node_body = $html_node->add_child("body"); $html_node_body->put_attrib( 'xmlns' => "http://www.w3.org/1999/xhtml", ); my $html_node_span = $html_node_body->add_child("span"); $html_node_span->put_attrib( 'style' => "font-weight: normal; font-size: 10pt; color: #ff0000; font-style: normal; font-family: arial black", ); $html_node_span->add_cdata("body"); my $x0038_node = $message_node->add_child("x"); $x0038_node->put_attrib(xmlns=>"jisp:x:jep-0038", ); my $name_38_node = $x0038_node->add_child("name"); $name_38_node->add_cdata("shinyicons"); is( $message_node->GetXML(), "bodybodyshinyicons", "GetXML()" ); #diag "Message Node ". pp($message_node); my $message = new Net::XMPP::Message($message_node); ok( defined($message), "new()" ); isa_ok( $message, "Net::XMPP::Message" ); is( $message->GetTo(), "jer\@jabber.org", "GetTo"); is( $message->GetFrom(), "reatmon\@jabber.org", "GetFrom"); is( $message->GetBody(), "body", "GetBody"); my @xdelays = $message->GetChild("jabber:x:delay"); is( @xdelays, 0, "no delays"); my $timestamp = $message->GetTimeStamp(); ok($timestamp, "GetTimeStamp"); #diag "Message ". pp($message); my $message_node2 = new XML::Stream::Node("message"); ok( defined($message_node2), "new()"); isa_ok( $message_node2, "XML::Stream::Node" ); $message_node2->put_attrib(to=>"jer\@jabber.org", from=>"reatmon\@jabber.org", type=>'groupchat', 'xml:lang'=>'en'); my $body_node2 = $message_node2->add_child("body"); $body_node2->add_cdata("body"); my $html_node2 = $message_node2->add_child("html"); $html_node2->put_attrib(xmlns=>"http://jabber.org/protocol/xhtml-im"); my $html_node2_body = $html_node2->add_child("body"); $html_node2_body->put_attrib( 'xmlns' => "http://www.w3.org/1999/xhtml", ); my $html_node2_span = $html_node2_body->add_child("span"); $html_node2_span->put_attrib( 'style' => "font-weight: normal; font-size: 10pt; color: #ff0000; font-style: normal; font-family: arial black", ); $html_node2_span->add_cdata("body"); my $x0038_node2 = $message_node2->add_child("x"); $x0038_node2->put_attrib(xmlns=>"jisp:x:jep-0038", ); my $name_38_node2 = $x0038_node2->add_child("name"); $name_38_node2->add_cdata("shinyicons"); #diag "Message Node2 ". $message_node2->GetXML; my $client = Net::XMPP::Client->new( 'debuglevel' => $debug_level, 'debugfile' => 'stderr', ); my $stream = new XML::Stream(style=>"node", 'debug' =>"stdout", 'debuglevel'=>$debug_level, ); $stream->SetCallBacks(node=>\&noder); $stream->OpenFile("t/node1.xml"); # What if there was a custom namespace $client->AddNamespace( ns => "tcli:request", tag => "tcli", xpath => { 'Version' => { 'path' => 'version/text()' }, 'Yaml' => { 'path' => 'yaml/text()' }, 'Request' => { 'type' => 'master'}, } ); $stream->OpenFile("t/node1.xml"); # What if there was a custom namespace that's in the node $client->AddNamespace( ns => "jisp:x:jep-0038", tag => "x", xpath => { 'Name' => { 'path' => 'name/text()' }, } ); $stream->OpenFile("t/node1.xml"); #$stream->OpenFile('./t/node2.xml'); sub noder { my ($sid,$node) = @_; #diag "Sid1 ".$sid." ".pp($node); is_deeply($node,$message_node2, " Nodes the same"); my $message = $client->BuildObject("message",$node); ok( defined($message), "new()" ); isa_ok( $message, "Net::XMPP::Message" ); my $timestamp = $message->GetTimeStamp(); #diag "Message ". pp($message); ok($timestamp, "GetTimeStamp"); }iq.t000444000000000000 1422210573310575 14441 0ustar00unknownunknown000000000000Net-XMPP-1.02/t#use lib "t/lib"; use Test::More tests=>115; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = new Net::XMPP::Debug(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); #------------------------------------------------------------------------------ # iq #------------------------------------------------------------------------------ my $iq = new Net::XMPP::IQ(); ok( defined($iq), "new()"); isa_ok( $iq, "Net::XMPP::IQ"); testScalar($iq, "Error", "error"); testScalar($iq, "ErrorCode", "401"); testJID($iq, "From", "user1", "server1", "resource1"); testScalar($iq, "ID", "id"); testJID($iq, "To", "user2", "server2", "resource2"); testScalar($iq, "Type", "Type"); is( $iq->DefinedChild("__netxmpptest__:child:test"), "", "not DefinedChild - __netxmpptest__:child:test" ); is( $iq->DefinedChild("__netxmpptest__:child:test:two"), "", "not DefinedChild - __netxmpptest__:child:test:two" ); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my $xoob = $iq->NewChild("__netxmpptest__:child:test"); ok( defined( $xoob ), "NewX - __netxmpptest__:child:test" ); isa_ok( $xoob, "Net::XMPP::Stanza" ); is( $iq->DefinedChild(), 1, "DefinedChild" ); is( $iq->DefinedChild("__netxmpptest__:child:test"), 1, "DefinedChild - __netxmpptest__:child:test" ); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x = $iq->GetChild(); is( $x[0], $xoob, "Is the first child the oob?"); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my $xroster = $iq->NewChild("__netxmpptest__:child:test:two"); ok( defined( $xoob ), "NewChild - __netxmpptest__:child:test:two" ); isa_ok( $xoob, "Net::XMPP::Stanza" ); is( $iq->DefinedChild(), 1, "DefinedChild" ); is( $iq->DefinedChild("__netxmpptest__:child:test"), 1, "DefinedChild - __netxmpptest__:child:test" ); is( $iq->DefinedChild("__netxmpptest__:child:test:two"), 1, "DefinedChild - __netxmpptest__:child:test:two" ); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x2 = $iq->GetChild(); is( $x2[0], $xoob, "Is the first child the oob?"); is( $x2[1], $xroster, "Is the second child the roster?"); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x3 = $iq->GetChild("__netxmpptest__:child:test"); is( $#x3, 0, "filter on xmlns - only one child... right?"); is( $x3[0], $xoob, "Is the first child the oob?"); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x4 = $iq->GetChild("__netxmpptest__:child:test:two"); is( $#x4, 0, "filter on xmlns - only one child... right?"); is( $x4[0], $xroster, "Is the first child the roster?"); is( $iq->DefinedChild("__netxmpptest__:child:test:three"), "", "not DefinedChild - __netxmpptest__:child:test:three" ); #------------------------------------------------------------------------------ # Query #------------------------------------------------------------------------------ my $child = $iq->GetQuery(); is($child, $xoob, "Is the query xoob?"); #------------------------------------------------------------------------------ # iq #------------------------------------------------------------------------------ my $iq2 = new Net::XMPP::IQ(); ok( defined($iq2), "new()"); isa_ok( $iq2, "Net::XMPP::IQ"); #------------------------------------------------------------------------------ # defined #------------------------------------------------------------------------------ is( $iq2->DefinedError(), '', "error not defined" ); is( $iq2->DefinedErrorCode(), '', "errorcode not defined" ); is( $iq2->DefinedFrom(), '', "from not defined" ); is( $iq2->DefinedID(), '', "id not defined" ); is( $iq2->DefinedTo(), '', "to not defined" ); is( $iq2->DefinedType(), '', "type not defined" ); #------------------------------------------------------------------------------ # set it #------------------------------------------------------------------------------ $iq2->SetIQ(error=>"error", errorcode=>"401", from=>"user1\@server1/resource1", id=>"id", to=>"user2\@server2/resource2", type=>"type"); testPostScalar($iq2, "Error", "error"); testPostScalar($iq2, "ErrorCode", "401"); testPostJID($iq2, "From", "user1", "server1", "resource1"); testPostScalar($iq2, "ID", "id"); testPostJID($iq2, "To", "user2", "server2", "resource2"); testPostScalar($iq2, "Type", "type"); is( $iq2->GetXML(), "error", "Full iq"); #------------------------------------------------------------------------------ # Reply #------------------------------------------------------------------------------ my $query = $iq2->NewChild("jabber:iq:roster"); my $reply = $iq2->Reply(); isa_ok($reply,"Net::XMPP::IQ"); testPostJID($reply, "From", "user2", "server2", "resource2"); testPostScalar($reply, "ID", "id"); testPostJID($reply, "To", "user1", "server1", "resource1"); testPostScalar($reply, "Type", "result"); is($reply->GetXML(),"","Reply - GetXML()"); #------------------------------------------------------------------------------ # Remove it #------------------------------------------------------------------------------ testRemove($iq2, "ErrorCode"); testRemove($iq2, "Error"); testRemove($iq2, "From"); testRemove($iq2, "ID"); testRemove($iq2, "To"); testRemove($iq2, "Type"); $iq2->RemoveChild("jabber:iq:roster"); is( $iq2->GetXML(), "", "Empty iq"); jid.t000444000000000000 171110573261145 14553 0ustar00unknownunknown000000000000Net-XMPP-1.02/tuse lib "t/lib"; use Test::More tests=>15; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $jid = new Net::XMPP::JID('host.com/xxx@yyy.com/zzz'); ok( defined($jid), "new()" ); isa_ok( $jid, "Net::XMPP::JID" ); is( $jid->GetUserID(), '', "GetUserID()" ); is( $jid->GetServer(), 'host.com', "GetServer()" ); is( $jid->GetResource(), 'xxx@yyy.com/zzz', "GetResource()" ); is( $jid->GetJID("full"), 'host.com/xxx@yyy.com/zzz', "GetJID(\"full\")" ); is( $jid->GetJID("base"), 'host.com', "GetJID(\"base\")" ); my $jid2 = new Net::XMPP::JID('user@host.com/xxx@yyy.com/zzz'); ok( defined($jid2), "new()" ); isa_ok( $jid2, "Net::XMPP::JID" ); is( $jid2->GetUserID(), 'user', "GetUserID()" ); is( $jid2->GetServer(), 'host.com', "GetServer()" ); is( $jid2->GetResource(), 'xxx@yyy.com/zzz', "GetResource()" ); is( $jid2->GetJID("full"), 'user@host.com/xxx@yyy.com/zzz', "GetJID(\"full\")" ); is( $jid2->GetJID("base"), 'user@host.com', "GetJID(\"base\")" ); message.t000444000000000000 1477210573543512 15465 0ustar00unknownunknown000000000000Net-XMPP-1.02/tuse lib "t/lib"; use Test::More tests=>136; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = new Net::XMPP::Debug(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); #------------------------------------------------------------------------------ # message #------------------------------------------------------------------------------ my $message = new Net::XMPP::Message(); ok( defined($message), "new()"); isa_ok( $message, "Net::XMPP::Message"); testScalar($message, "Body", "body"); testScalar($message, "Error", "error"); testScalar($message, "ErrorCode", "401"); testJID($message, "From", "user1", "server1", "resource1"); testScalar($message, "ID", "id"); testScalar($message, "Subject", "subject"); testScalar($message, "Thread", "thread"); testJID($message, "To", "user2", "server2", "resource2"); testScalar($message, "Type", "Type"); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my $xoob = $message->NewChild("__netxmpptest__:child:test"); ok( defined( $xoob ), "NewX - __netxmpptest__:child:test" ); isa_ok( $xoob, "Net::XMPP::Stanza" ); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x = $message->GetChild(); is( $x[0], $xoob, "Is the first x the oob?"); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my $xroster = $message->NewChild("__netxmpptest__:child:test:two"); ok( defined( $xoob ), "NewX - __netxmpptest__:child:test:two" ); isa_ok( $xoob, "Net::XMPP::Stanza" ); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x2 = $message->GetChild(); is( $x2[0], $xoob, "Is the first child test?"); is( $x2[1], $xroster, "Is the second child test two?"); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x3 = $message->GetChild("__netxmpptest__:child:test"); is( $#x3, 0, "filter on xmlns - only one child... right?"); is( $x3[0], $xoob, "Is the first child the oob?"); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x4 = $message->GetChild("__netxmpptest__:child:test:two"); is( $#x4, 0, "filter on xmlns - only one x... right?"); is( $x4[0], $xroster, "Is the first x the roster?"); ok( $message->DefinedChild(), "DefinedChild - yes"); ok( $message->DefinedChild("__netxmpptest__:child:test:two"), "DefinedChild - __netxmpptest__:child:test:two - yes"); ok( $message->DefinedChild("__netxmpptest__:child:test"), "DefinedChild - __netxmpptest__:child:test - yes"); ok( !$message->DefinedChild("foo:bar"), "DefinedChild - foo:bar - no"); #------------------------------------------------------------------------------ # message #------------------------------------------------------------------------------ my $message2 = new Net::XMPP::Message(); ok( defined($message2), "new()"); isa_ok( $message2, "Net::XMPP::Message"); #------------------------------------------------------------------------------ # defined #------------------------------------------------------------------------------ is( $message2->DefinedBody(), '', "body not defined" ); is( $message2->DefinedError(), '', "error not defined" ); is( $message2->DefinedErrorCode(), '', "errorcode not defined" ); is( $message2->DefinedFrom(), '', "from not defined" ); is( $message2->DefinedID(), '', "id not defined" ); is( $message2->DefinedSubject(), '', "subject not defined" ); is( $message2->DefinedThread(), '', "thread not defined" ); is( $message2->DefinedTo(), '', "to not defined" ); is( $message2->DefinedType(), '', "type not defined" ); #------------------------------------------------------------------------------ # set it #------------------------------------------------------------------------------ $message2->SetMessage(body=>"body", error=>"error", errorcode=>"401", from=>"user1\@server1/resource1", id=>"id", subject=>"subject", thread=>"thread", to=>"user2\@server2/resource2", type=>"type"); testPostScalar($message2, "Body", "body"); testPostScalar($message2, "Error", "error"); testPostScalar($message2, "ErrorCode", "401"); testPostJID($message2, "From", "user1", "server1", "resource1"); testPostScalar($message2, "ID", "id"); testPostScalar($message2, "Subject", "subject"); testPostScalar($message2, "Thread", "thread"); testPostJID($message2, "To", "user2", "server2", "resource2"); testPostScalar($message2, "Type", "type"); is( $message2->GetXML(), "bodyerrorsubjectthread", "Full message"); #------------------------------------------------------------------------------ # Reply #------------------------------------------------------------------------------ testRemove($message2, "Type"); my $reply = $message2->Reply(); isa_ok($reply,"Net::XMPP::Message"); testPostJID($reply, "From", "user2", "server2", "resource2"); testPostScalar($reply, "ID", "id"); testPostScalar($reply, "Subject", "re: subject"); testPostScalar($reply, "Thread", "thread"); testPostJID($reply, "To", "user1", "server1", "resource1"); is( $reply->GetXML(), "re: subjectthread", "Reply - GetXML()" ); #------------------------------------------------------------------------------ # Remove it #------------------------------------------------------------------------------ testRemove($message2, "Body"); testRemove($message2, "ErrorCode"); testRemove($message2, "Error"); testRemove($message2, "From"); testRemove($message2, "ID"); testRemove($message2, "Subject"); testRemove($message2, "Thread"); testRemove($message2, "To"); is( $message2->GetXML(), "", "Empty message"); mytestlib.pl000444000000000000 725710573306604 16204 0ustar00unknownunknown000000000000Net-XMPP-1.02/t sub testDefined { my ($obj, $tag, $name) = @_; my $ltag = lc($tag); $name = "" unless defined $name; my $defined; eval "\$defined = \$obj->Defined$tag();"; die($@) if ($@); is( $defined, 1, "$name: $ltag defined" ); } sub testNotDefined { my ($obj, $tag, $name) = @_; my $ltag = lc($tag); $name = "" unless defined $name; my $defined; eval "\$defined = \$obj->Defined$tag();"; die($@) if ($@); is( $defined, '', "$name: $ltag not defined" ); } sub testDefinedField { my ($hash, $tag) = @_; my $ltag = lc($tag); ok( exists($hash->{$ltag}), "$ltag defined" ); } sub testScalar { my ($obj, $tag, $value) = @_; my $ltag = lc($tag); testNotDefined($obj, $tag, "Scalar"); testSetScalar(@_); } sub testSetScalar { my ($obj, $tag, $value) = @_; my $ltag = lc($tag); eval "\$obj->Set$tag(\$value);"; die($@) if ($@); testPostScalar(@_); } sub testRemove { my ($obj, $tag) = @_; my $ltag = lc($tag); testDefined($obj, $tag, "Remove"); eval "\$obj->Remove$tag();"; die($@) if ($@); testNotDefined($obj, $tag, "Remove"); } sub testPostScalar { my ($obj, $tag, $value) = @_; my $ltag = lc($tag); testDefined($obj, $tag, "PostScalar"); my $get; eval "\$get = \$obj->Get$tag();"; die($@) if ($@); is( $get, $value, "$ltag eq '$value'" ); } sub testFieldScalar { my ($hash, $tag, $value) = @_; my $ltag = lc($tag); testDefinedField(@_); is( $hash->{$ltag}, $value , "$ltag eq '$value'"); } sub testFlag { my ($obj, $tag) = @_; my $ltag = lc($tag); testNotDefined($obj,$tag,"Flag"); my $get; eval "\$get = \$obj->Get$tag();"; die($@) if ($@); is( $get, '', "$ltag is not set" ); testSetFlag(@_); } sub testSetFlag { my ($obj, $tag) = @_; my $ltag = lc($tag); eval "\$obj->Set$tag();"; die($@) if ($@); testPostFlag(@_); } sub testPostFlag { my ($obj, $tag) = @_; my $ltag = lc($tag); testDefined($obj, $tag, "PostFlag"); my $get; eval "\$get = \$obj->Get$tag();"; die($@) if ($@); is( $get, 1, "$ltag is set" ); } sub testFieldFlag { my ($hash, $tag) = @_; my $ltag = lc($tag); testDefinedField(@_); is( $hash->{$ltag}, 1 , "$ltag is set"); } sub testJID { my ($obj, $tag, $user, $server, $resource) = @_; my $ltag = lc($tag); testNotDefined($obj, $tag, "JID"); testSetJID(@_); } sub testSetJID { my ($obj, $tag, $user, $server, $resource) = @_; my $ltag = lc($tag); my $value = $user.'@'.$server.'/'.$resource; eval "\$obj->Set$tag(\$value);"; die($@) if ($@); testPostJID(@_); } sub testPostJID { my ($obj, $tag, $user, $server, $resource) = @_; my $ltag = lc($tag); my $value = $user.'@'.$server.'/'.$resource; testDefined($obj, $tag,"PostJID"); my $get; eval "\$get = \$obj->Get$tag();"; die($@) if ($@); is( $get, $value, "$ltag eq '$value'" ); my $jid; eval "\$jid = \$obj->Get$tag(\"jid\");"; die($@) if ($@); ok( defined($jid), "jid object defined"); isa_ok( $jid, 'Net::XMPP::JID'); is( $jid->GetUserID(), $user , "user eq '$user'"); is( $jid->GetServer(), $server , "server eq '$server'"); is( $jid->GetResource(), $resource , "resource eq '$resource'"); } sub testFieldJID { my ($hash, $tag, $user, $server, $resource) = @_; my $ltag = lc($tag); testDefined( $obj, $tag, "FieldJID"); my $jid = $hash->{$ltag}; isa_ok( $jid, 'Net::XMPP::JID'); is( $jid->GetUserID(), $user , "user eq '$user'"); is( $jid->GetServer(), $server , "server eq '$server'"); is( $jid->GetResource(), $resource , "resource eq '$resource'"); } 1; node1.xml000444000000000000 64010573431315 15326 0ustar00unknownunknown000000000000Net-XMPP-1.02/tbodybodyshinyicons node2.xml000444000000000000 66210573431257 15340 0ustar00unknownunknown000000000000Net-XMPP-1.02/tRedRedshinyiconspacket_iqauth.t000444000000000000 431410573261145 16631 0ustar00unknownunknown000000000000Net-XMPP-1.02/tuse lib "t/lib"; use Test::More tests=>55; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = new Net::XMPP::Debug(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); my $query = new Net::XMPP::Stanza("query"); ok( defined($query), "new()" ); isa_ok( $query, "Net::XMPP::Stanza" ); testScalar($query,"XMLNS","jabber:iq:auth"); testScalar($query,"Digest","digest"); testScalar($query,"Hash","hash"); testScalar($query,"Password","password"); testScalar($query,"Resource","resource"); testScalar($query,"Sequence","sequence"); testScalar($query,"Token","token"); testScalar($query,"Username","username"); is( $query->GetXML(), "digesthashpasswordresourcesequencetokenusername", "GetXML()" ); my $query2 = new Net::XMPP::Stanza("query"); ok( defined($query2), "new()" ); isa_ok( $query2, "Net::XMPP::Stanza" ); testScalar($query2,"XMLNS","jabber:iq:auth"); testNotDefined($query2,"Digest"); testNotDefined($query2,"Hash"); testNotDefined($query2,"Password"); testNotDefined($query2,"Resource"); testNotDefined($query2,"Sequence"); testNotDefined($query2,"Token"); testNotDefined($query2,"Username"); $query2->SetAuth(digest=>"digest", hash=>"hash", password=>"password", resource=>"resource", sequence=>"sequence", token=>"token", username=>"username"); testPostScalar($query,"Digest","digest"); testPostScalar($query,"Hash","hash"); testPostScalar($query,"Password","password"); testPostScalar($query,"Resource","resource"); testPostScalar($query,"Sequence","sequence"); testPostScalar($query,"Token","token"); testPostScalar($query,"Username","username"); is( $query2->GetXML(), "digesthashpasswordresourcesequencetokenusername", "GetXML()" ); packet_iqroster.t000444000000000000 626210573261145 17212 0ustar00unknownunknown000000000000Net-XMPP-1.02/tuse lib "t/lib"; use Test::More tests=>57; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = new Net::XMPP::Debug(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); my $query = new Net::XMPP::Stanza("query"); ok( defined($query), "new()" ); isa_ok( $query, "Net::XMPP::Stanza" ); testScalar($query,"XMLNS","jabber:iq:roster"); my $item1 = $query->AddItem(); ok( defined($item1), "new()" ); isa_ok( $item1, "Net::XMPP::Stanza" ); testScalar($item1,"Ask","ask"); testScalar($item1,"Group","groupA"); my @groups = $item1->GetGroup(); is( $#groups, 0, "is there one group?" ); is( $groups[0], "groupA", "groupA" ); testJID($item1,"JID","user1","server1","resource1"); testScalar($item1,"Name","name"); testScalar($item1,"Subscription","from"); is( $query->GetXML(), "groupA", "GetXML()" ); my $item2 = $query->AddItem(ask=>"ask", group=>["group1","group2"], jid=>"user2\@server2/resource2", name=>"name2", subscription=>"both" ); ok( defined($item2), "new()" ); isa_ok( $item2, "Net::XMPP::Stanza" ); testPostScalar($item2,"Ask","ask"); @groups = $item2->GetGroup(); is( $#groups, 1, "are there two groups?" ); is( $groups[0], "group1", "group1" ); is( $groups[1], "group2", "group2" ); testPostJID($item2,"JID","user2","server2","resource2"); testPostScalar($item2,"Name","name2"); testPostScalar($item2,"Subscription","both"); is( $query->GetXML(), "groupAgroup1group2", "GetXML()" ); my $item3 = $query->AddItem(ask=>"ask", jid=>"user3\@server3/resource3", subscription=>"both" ); ok( defined($item3), "new()" ); isa_ok( $item3, "Net::XMPP::Stanza" ); is( $query->GetXML(), "groupAgroup1group2", "GetXML()" ); my @items = $query->GetItems(); is( $#items, 2, "are there three items?" ); is( $items[0]->GetXML(), "groupA", "GetXML()" ); is( $items[1]->GetXML(), "group1group2", "GetXML()" ); is( $items[2]->GetXML(), "", "GetXML()" ); presence.t000444000000000000 1467410573261145 15645 0ustar00unknownunknown000000000000Net-XMPP-1.02/tuse lib "t/lib"; use Test::More tests=>132; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = new Net::XMPP::Debug(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); #------------------------------------------------------------------------------ # presence #------------------------------------------------------------------------------ my $presence = new Net::XMPP::Presence(); ok( defined($presence), "new()"); isa_ok( $presence, "Net::XMPP::Presence"); testScalar($presence, "Error", "error"); testScalar($presence, "ErrorCode", "401"); testJID($presence, "From", "user1", "server1", "resource1"); testScalar($presence, "ID", "id"); testScalar($presence, "Priority", "priority"); testScalar($presence, "Show", "show"); testScalar($presence, "Status", "status"); testJID($presence, "To", "user2", "server2", "resource2"); testScalar($presence, "Type", "Type"); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my $xoob = $presence->NewChild("__netxmpptest__:child:test"); ok( defined( $xoob ), "NewX - __netxmpptest__:child:test" ); isa_ok( $xoob, "Net::XMPP::Stanza" ); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x = $presence->GetChild(); is( $x[0], $xoob, "Is the first x the oob?"); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my $xroster = $presence->NewChild("__netxmpptest__:child:test:two"); ok( defined( $xoob ), "NewX - __netxmpptest__:child:test:two" ); isa_ok( $xoob, "Net::XMPP::Stanza" ); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x2 = $presence->GetChild(); is( $x2[0], $xoob, "Is the first child test?"); is( $x2[1], $xroster, "Is the second child test two?"); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x3 = $presence->GetChild("__netxmpptest__:child:test"); is( $#x3, 0, "filter on xmlns - only one child... right?"); is( $x3[0], $xoob, "Is the first child the oob?"); #------------------------------------------------------------------------------ # X #------------------------------------------------------------------------------ my @x4 = $presence->GetChild("__netxmpptest__:child:test:two"); is( $#x4, 0, "filter on xmlns - only one x... right?"); is( $x4[0], $xroster, "Is the first x the roster?"); ok( $presence->DefinedChild(), "DefinedChild - yes"); ok( $presence->DefinedChild("__netxmpptest__:child:test:two"), "DefinedChild - __netxmpptest__:child:test:two - yes"); ok( $presence->DefinedChild("__netxmpptest__:child:test"), "DefinedChild - __netxmpptest__:child:test - yes"); ok( !$presence->DefinedChild("foo:bar"), "DefinedChild - foo:bar - no"); #------------------------------------------------------------------------------ # presence #------------------------------------------------------------------------------ my $presence2 = new Net::XMPP::Presence(); ok( defined($presence2), "new()"); isa_ok( $presence2, "Net::XMPP::Presence"); #------------------------------------------------------------------------------ # defined #------------------------------------------------------------------------------ is( $presence2->DefinedError(), '', "error not defined" ); is( $presence2->DefinedErrorCode(), '', "errorcode not defined" ); is( $presence2->DefinedFrom(), '', "from not defined" ); is( $presence2->DefinedID(), '', "id not defined" ); is( $presence2->DefinedPriority(), '', "priority not defined" ); is( $presence2->DefinedShow(), '', "show not defined" ); is( $presence2->DefinedStatus(), '', "status not defined" ); is( $presence2->DefinedTo(), '', "to not defined" ); is( $presence2->DefinedType(), '', "type not defined" ); #------------------------------------------------------------------------------ # set it #------------------------------------------------------------------------------ $presence2->SetPresence(error=>"error", errorcode=>"401", from=>"user1\@server1/resource1", id=>"id", priority=>"priority", show=>"show", status=>"status", to=>"user2\@server2/resource2", type=>"type"); testPostScalar($presence2, "Error", "error"); testPostScalar($presence2, "ErrorCode", "401"); testPostJID($presence2, "From", "user1", "server1", "resource1"); testPostScalar($presence2, "ID", "id"); testPostScalar($presence2, "Priority", "priority"); testPostScalar($presence2, "Show", "show"); testPostScalar($presence2, "Status", "status"); testPostJID($presence2, "To", "user2", "server2", "resource2"); testPostScalar($presence2, "Type", "type"); is( $presence2->GetXML(), "errorpriorityshowstatus", "Full presence"); #------------------------------------------------------------------------------ # Reply #------------------------------------------------------------------------------ my $reply = $presence2->Reply(); isa_ok($reply,"Net::XMPP::Presence"); testPostJID($reply, "From", "user2", "server2", "resource2"); testPostScalar($reply, "ID", "id"); testPostJID($reply, "To", "user1", "server1", "resource1"); is($reply->GetXML(),"","Reply - GetXML()"); #------------------------------------------------------------------------------ # Remove it #------------------------------------------------------------------------------ testRemove($presence2, "ErrorCode"); testRemove($presence2, "Error"); testRemove($presence2, "From"); testRemove($presence2, "ID"); testRemove($presence2, "Priority"); testRemove($presence2, "Show"); testRemove($presence2, "Status"); testRemove($presence2, "To"); testRemove($presence2, "Type"); is( $presence2->GetXML(), "", "Empty presence"); query_xxxxx.test000444000000000000 204610601747451 17160 0ustar00unknownunknown000000000000Net-XMPP-1.02/tuse lib "t/lib"; use Test::More tests=>1; BEGIN{ use_ok( "Net::Jabber","Client" ); } exit(0); require "t/mytestlib.pl"; my $query = new Net::Jabber::Query(); ok( defined($query), "new()" ); isa_ok( $query, "Net::Jabber::Query" ); testScalar($query,"XMLNS","jabber:iq:"); testScalar($query,"",""); testScalar($query,"",""); testScalar($query,"",""); testScalar($query,"",""); testScalar($query,"",""); testScalar($query,"",""); testScalar($query,"",""); testScalar($query,"",""); print $query->GetXML(),"\n"; is( $query->GetXML(), "", "GetXML()" ); my $query2 = new Net::Jabber::Query(); ok( defined($query2), "new()" ); isa_ok( $query2, "Net::Jabber::Query" ); testScalar($query2,"XMLNS","jabber:iq:"); $query2->Set(); testPostScalar($query2,); testPostScalar($query2,); testPostScalar($query2,); testPostScalar($query2,); testPostScalar($query2,); testPostScalar($query2,); testPostScalar($query2,); testPostScalar($query2,); print $query2->GetXML(),"\n"; is( $query2->GetXML(), "", "GetXML()" ); rawxml.t000444000000000000 405510573261145 15323 0ustar00unknownunknown000000000000Net-XMPP-1.02/tuse lib "t/lib"; use Test::More tests=>54; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $message = new Net::XMPP::Message(); ok( defined($message), "new()"); isa_ok( $message, "Net::XMPP::Message"); testScalar($message, "Body", "body"); testJID($message, "From", "user1", "server1", "resource1"); testScalar($message, "Subject", "subject"); testJID($message, "To", "user2", "server2", "resource2"); $message->InsertRawXML("bar"); $message->InsertRawXML("foo"); is( $message->GetXML(), "bodysubjectbarfoo", "GetXML()" ); $message->ClearRawXML(); is( $message->GetXML(), "bodysubject", "GetXML()" ); $message->InsertRawXML("foo"); is( $message->GetXML(), "bodysubjectfoo", "GetXML()" ); my $iq = new Net::XMPP::IQ(); ok( defined($iq), "new()"); isa_ok( $iq, "Net::XMPP::IQ"); testJID($iq, "From", "user1", "server1", "resource1"); testJID($iq, "To", "user2", "server2", "resource2"); my $query = $iq->NewChild("jabber:iq:auth"); ok( defined($query), "NewChild()"); isa_ok( $query, "Net::XMPP::Stanza" ); testPostScalar( $query, "XMLNS", "jabber:iq:auth"); is( $iq->GetXML(), "", "GetXML()"); $iq->InsertRawXML(""); is( $iq->GetXML(), "", "GetXML()"); $query->InsertRawXML(""); is( $query->GetXML(), "", "GetXML()"); is( $iq->GetXML(), "", "GetXML()"); roster.t000444000000000000 1521710573261145 15351 0ustar00unknownunknown000000000000Net-XMPP-1.02/tuse lib "t/lib"; use Test::More tests=>75; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = new Net::XMPP::Debug(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); #------------------------------------------------------------------------------ # Client #------------------------------------------------------------------------------ my $Client = new Net::XMPP::Client(); ok( defined($Client), "new()"); isa_ok($Client,"Net::XMPP::Client"); isa_ok($Client,"Net::XMPP::Connection"); #------------------------------------------------------------------------------ # Roster #------------------------------------------------------------------------------ my $Roster = new Net::XMPP::Roster(connection=>$Client); ok( defined($Roster), "new()"); isa_ok($Roster,"Net::XMPP::Roster"); my $jid1 = 'test1@example.com'; my $res1 = "Work"; my $res2 = "Home"; my $jid2 = 'test2@example.com'; my $group1 = 'Test1'; my $group2 = 'Test2'; #------------------------------------------------------------------------------ # Add JIDs to Roster #------------------------------------------------------------------------------ ok( !$Roster->exists($jid1), "jid1 does not exist"); ok( !$Roster->exists($jid2), "jid2 does not exist"); $Roster->add($jid1); ok( $Roster->exists($jid1), "jid1 exists"); ok( !$Roster->exists($jid2), "jid2 does not exist"); ok( !$Roster->groupExists($group1), "group1 does not exist"); ok( !$Roster->groupExists($group2), "group2 does not exist"); $Roster->add($jid2, ask => "no", groups => [ $group1, $group2 ], name => "Test", subscription => "both", ); ok( $Roster->exists($jid1), "jid1 exists"); ok( $Roster->exists($jid2), "jid2 exists"); ok( $Roster->groupExists($group1), "group1 exists"); ok( $Roster->groupExists($group2), "group2 exists"); my @jids = $Roster->jids("all"); is($#jids, 1, "all - two jids"); ok(($jids[0]->GetJID() eq $jid1) || ($jids[1]->GetJID() eq $jid1), "all - jid1 matched"); ok(($jids[0]->GetJID() eq $jid2) || ($jids[1]->GetJID() eq $jid2), "all - jid2 matched"); @jids = $Roster->jids("group",$group1); is($#jids, 0, "group - $group1 - one jid"); is($jids[0]->GetJID(), $jid2, "group - $group1 - jid2 matched"); @jids = $Roster->jids("group",$group2); is($#jids, 0, "group - $group2 - one jid"); is($jids[0]->GetJID(), $jid2, "group - $group2 - jid2 matched"); @jids = $Roster->jids("nogroup"); is($#jids, 0, "nogroup - one jid"); is($jids[0]->GetJID(), $jid1, "nogroup - jid1 matched"); my %query = $Roster->query($jid1); is_deeply( \%query, { }, "jid1 - query"); %query = $Roster->query($jid2); is_deeply( \%query, { ask=>"no",groups=>[$group1,$group2],name=>"Test",subscription=>"both"}, "jid2 - query"); is( $Roster->query($jid2,"name"), "Test", "jid1 - name == Test"); is( $Roster->query($jid2,"foo"), undef, "jid1 - foo does not exist"); $Roster->store($jid2,"foo","bar"); is( $Roster->query($jid2,"name"), "Test", "jid1 - name == Test"); is( $Roster->query($jid2,"foo"), "bar", "jid1 - foo == bar"); #------------------------------------------------------------------------------ # Simulate presence #------------------------------------------------------------------------------ ok( !$Roster->online($jid1), "jid1 not online"); ok( !$Roster->online($jid2), "jid2 not online"); $Roster->addResource($jid1, $res1); ok( $Roster->online($jid1), "jid1 online"); ok( !$Roster->online($jid2), "jid2 not online"); is( $Roster->resource($jid1), $res1, "jid1 resource matches"); $Roster->addResource($jid1, $res2, priority => 100, show => "xa", status => "test", ); ok( $Roster->online($jid1), "jid1 online"); ok( !$Roster->online($jid2), "jid2 not online"); is( $Roster->resource($jid1), $res2, "jid1 resource matches"); my @resources = $Roster->resources($jid1); is( $#resources, 1, "two resources"); is( $resources[0], $res2, "res2 is highest"); is( $resources[1], $res1, "res1 is lowest"); @resources = $Roster->resources($jid2); is( $#resources, -1, "no resources"); my %resQuery = $Roster->resourceQuery($jid1,$res1); is_deeply( \%resQuery, { priority => 0 }, "jid1/res1 - query"); %resQuery = $Roster->resourceQuery($jid1,$res2); is_deeply( \%resQuery, { priority=>100, show=>"xa", status=>"test"}, "jid1/res2 - query"); is( $Roster->resourceQuery($jid1,$res2,"show"), "xa", "jid2/res2 - show == xa"); is( $Roster->resourceQuery($jid1,$res2,"foo"), undef, "jid2/res2 - foo does not exist"); $Roster->resourceStore($jid1,$res2,"foo","bar"); %resQuery = $Roster->resourceQuery($jid1,$res2); is_deeply( \%resQuery, { foo=>"bar",priority=>100, show=>"xa", status=>"test"}, "jid1/res2 - query"); is( $Roster->resourceQuery($jid1,$res2,"show"), "xa", "jid2/res2 - show == xa"); is( $Roster->resourceQuery($jid1,$res2,"foo"), "bar", "jid2/res2 - foo == bar"); ok( $Roster->online($jid1), "jid1 online"); ok( !$Roster->online($jid2), "jid2 not online"); $Roster->removeResource($jid1, $res2); is( $Roster->resource($jid1), $res1, "jid1 resource matches"); @resources = $Roster->resources($jid1); is( $#resources, 0, "one resource"); is( $resources[0], $res1, "res1 is highest"); ok( $Roster->online($jid1), "jid1 online"); ok( !$Roster->online($jid2), "jid2 not online"); $Roster->removeResource($jid1, $res1); is( $Roster->resource($jid1), undef, "jid1 no resources"); @resources = $Roster->resources($jid1); is( $#resources, -1, "no resources"); ok( !$Roster->online($jid1), "jid1 not online"); ok( !$Roster->online($jid2), "jid2 not online"); #----------------------------------------------------------------------------- # Remove JIDs #----------------------------------------------------------------------------- ok( $Roster->exists($jid1), "jid1 exists"); ok( $Roster->exists($jid2), "jid2 exists"); @jids = $Roster->jids("all"); is($#jids, 1, "all - two jids"); ok(($jids[0]->GetJID() eq $jid1) || ($jids[1]->GetJID() eq $jid1), "all - jid1 matched"); ok(($jids[0]->GetJID() eq $jid2) || ($jids[1]->GetJID() eq $jid2), "all - jid2 matched"); $Roster->remove($jid2); ok( !$Roster->groupExists($group1), "group1 does not exist"); ok( !$Roster->groupExists($group2), "group2 does not exist"); ok( $Roster->exists($jid1), "jid1 exists"); ok( !$Roster->exists($jid2), "jid2 does not exist"); @jids = $Roster->jids("all"); is($#jids, 0, "all - one jid"); is($jids[0]->GetJID(), $jid1, "all - jid1 matched"); $Roster->clear(); ok( !$Roster->exists($jid1), "jid1 does not exist"); ok( !$Roster->exists($jid2), "jid2 does not exist"); @jids = $Roster->jids("all"); is($#jids, -1, "all - no jids"); lib000777000000000000 010603223625 14230 5ustar00unknownunknown000000000000Net-XMPP-1.02/tTest000777000000000000 010603223625 15147 5ustar00unknownunknown000000000000Net-XMPP-1.02/t/libBuilder.pm000444000000000000 7377310573261145 17272 0ustar00unknownunknown000000000000Net-XMPP-1.02/t/lib/Testpackage Test::Builder; use 5.004; # $^C was only introduced in 5.005-ish. We do this to prevent # use of uninitialized value warnings in older perls. $^C ||= 0; use strict; use vars qw($VERSION $CLASS); $VERSION = '0.17'; $CLASS = __PACKAGE__; my $IsVMS = $^O eq 'VMS'; # Make Test::Builder thread-safe for ithreads. BEGIN { use Config; if( $] >= 5.008 && $Config{useithreads} ) { require threads; require threads::shared; threads::shared->import; } else { *share = sub { 0 }; *lock = sub { 0 }; } } use vars qw($Level); my($Test_Died) = 0; my($Have_Plan) = 0; my $Original_Pid = $$; my $Curr_Test = 0; share($Curr_Test); my @Test_Results = (); share(@Test_Results); my @Test_Details = (); share(@Test_Details); =head1 NAME Test::Builder - Backend for building test libraries =head1 SYNOPSIS package My::Test::Module; use Test::Builder; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(ok); my $Test = Test::Builder->new; $Test->output('my_logfile'); sub import { my($self) = shift; my $pack = caller; $Test->exported_to($pack); $Test->plan(@_); $self->export_to_level(1, $self, 'ok'); } sub ok { my($test, $name) = @_; $Test->ok($test, $name); } =head1 DESCRIPTION Test::Simple and Test::More have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides the a building block upon which to write your own test libraries I. =head2 Construction =over 4 =item B my $Test = Test::Builder->new; Returns a Test::Builder object representing the current state of the test. Since you only run one test per program, there is B Test::Builder object. No matter how many times you call new(), you're getting the same object. (This is called a singleton). =cut my $Test; sub new { my($class) = shift; $Test ||= bless ['Move along, nothing to see here'], $class; return $Test; } =back =head2 Setting up tests These methods are for setting up tests and declaring how many there are. You usually only want to call one of these methods. =over 4 =item B my $pack = $Test->exported_to; $Test->exported_to($pack); Tells Test::Builder what package you exported your functions to. This is important for getting TODO tests right. =cut my $Exported_To; sub exported_to { my($self, $pack) = @_; if( defined $pack ) { $Exported_To = $pack; } return $Exported_To; } =item B $Test->plan('no_plan'); $Test->plan( skip_all => $reason ); $Test->plan( tests => $num_tests ); A convenient way to set up your tests. Call this and Test::Builder will print the appropriate headers and take the appropriate actions. If you call plan(), don't call any of the other methods below. =cut sub plan { my($self, $cmd, $arg) = @_; return unless $cmd; if( $Have_Plan ) { die sprintf "You tried to plan twice! Second plan at %s line %d\n", ($self->caller)[1,2]; } if( $cmd eq 'no_plan' ) { $self->no_plan; } elsif( $cmd eq 'skip_all' ) { return $self->skip_all($arg); } elsif( $cmd eq 'tests' ) { if( $arg ) { return $self->expected_tests($arg); } elsif( !defined $arg ) { die "Got an undefined number of tests. Looks like you tried to ". "say how many tests you plan to run but made a mistake.\n"; } elsif( !$arg ) { die "You said to run 0 tests! You've got to run something.\n"; } } else { require Carp; my @args = grep { defined } ($cmd, $arg); Carp::croak("plan() doesn't understand @args"); } return 1; } =item B my $max = $Test->expected_tests; $Test->expected_tests($max); Gets/sets the # of tests we expect this test to run and prints out the appropriate headers. =cut my $Expected_Tests = 0; sub expected_tests { my($self, $max) = @_; if( defined $max ) { $Expected_Tests = $max; $Have_Plan = 1; $self->_print("1..$max\n") unless $self->no_header; } return $Expected_Tests; } =item B $Test->no_plan; Declares that this test will run an indeterminate # of tests. =cut my($No_Plan) = 0; sub no_plan { $No_Plan = 1; $Have_Plan = 1; } =item B $plan = $Test->has_plan Find out whether a plan has been defined. $plan is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). =cut sub has_plan { return($Expected_Tests) if $Expected_Tests; return('no_plan') if $No_Plan; return(undef); }; =item B $Test->skip_all; $Test->skip_all($reason); Skips all the tests, using the given $reason. Exits immediately with 0. =cut my $Skip_All = 0; sub skip_all { my($self, $reason) = @_; my $out = "1..0"; $out .= " # Skip $reason" if $reason; $out .= "\n"; $Skip_All = 1; $self->_print($out) unless $self->no_header; exit(0); } =back =head2 Running tests These actually run the tests, analogous to the functions in Test::More. $name is always optional. =over 4 =item B $Test->ok($test, $name); Your basic test. Pass if $test is true, fail if $test is false. Just like Test::Simple's ok(). =cut sub ok { my($self, $test, $name) = @_; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run a test without a plan! Gotta have a plan."); } lock $Curr_Test; $Curr_Test++; $self->diag(<caller; my $todo = $self->todo($pack); my $out; my $result = {}; share($result); unless( $test ) { $out .= "not "; @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); } $out .= "ok"; $out .= " $Curr_Test" if $self->use_numbers; if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $out .= " - $name"; $result->{name} = $name; } else { $result->{name} = ''; } if( $todo ) { my $what_todo = $todo; $out .= " # TODO $what_todo"; $result->{reason} = $what_todo; $result->{type} = 'todo'; } else { $result->{reason} = ''; $result->{type} = ''; } $Test_Results[$Curr_Test-1] = $result; $out .= "\n"; $self->_print($out); unless( $test ) { my $msg = $todo ? "Failed (TODO)" : "Failed"; $self->diag(" $msg test ($file at line $line)\n"); } return $test ? 1 : 0; } =item B $Test->is_eq($got, $expected, $name); Like Test::More's is(). Checks if $got eq $expected. This is the string version. =item B $Test->is_num($got, $expected, $name); Like Test::More's is(). Checks if $got == $expected. This is the numeric version. =cut sub is_eq { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok($test, $name); $self->_is_diag($got, 'eq', $expect) unless $test; return $test; } return $self->cmp_ok($got, 'eq', $expect, $name); } sub is_num { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok($test, $name); $self->_is_diag($got, '==', $expect) unless $test; return $test; } return $self->cmp_ok($got, '==', $expect, $name); } sub _is_diag { my($self, $got, $type, $expect) = @_; foreach my $val (\$got, \$expect) { if( defined $$val ) { if( $type eq 'eq' ) { # quote and force string context $$val = "'$$val'" } else { # force numeric context $$val = $$val+0; } } else { $$val = 'undef'; } } return $self->diag(sprintf < $Test->isnt_eq($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the string version. =item B $Test->is_num($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the numeric version. =cut sub isnt_eq { my($self, $got, $dont_expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok($test, $name); $self->_cmp_diag('ne', $got, $dont_expect) unless $test; return $test; } return $self->cmp_ok($got, 'ne', $dont_expect, $name); } sub isnt_num { my($self, $got, $dont_expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok($test, $name); $self->_cmp_diag('!=', $got, $dont_expect) unless $test; return $test; } return $self->cmp_ok($got, '!=', $dont_expect, $name); } =item B $Test->like($this, qr/$regex/, $name); $Test->like($this, '/$regex/', $name); Like Test::More's like(). Checks if $this matches the given $regex. You'll want to avoid qr// if you want your tests to work before 5.005. =item B $Test->unlike($this, qr/$regex/, $name); $Test->unlike($this, '/$regex/', $name); Like Test::More's unlike(). Checks if $this B the given $regex. =cut sub like { my($self, $this, $regex, $name) = @_; local $Level = $Level + 1; $self->_regex_ok($this, $regex, '=~', $name); } sub unlike { my($self, $this, $regex, $name) = @_; local $Level = $Level + 1; $self->_regex_ok($this, $regex, '!~', $name); } =item B $Test->maybe_regex(qr/$regex/); $Test->maybe_regex('/$regex/'); Convenience method for building testing functions that take regular expressions as arguments, but need to work before perl 5.005. Takes a quoted regular expression produced by qr//, or a string representing a regular expression. Returns a Perl value which may be used instead of the corresponding regular expression, or undef if it's argument is not recognised. For example, a version of like(), sans the useful diagnostic messages, could be written as: sub laconic_like { my ($self, $this, $regex, $name) = @_; my $usable_regex = $self->maybe_regex($regex); die "expecting regex, found '$regex'\n" unless $usable_regex; $self->ok($this =~ m/$usable_regex/, $name); } =cut sub maybe_regex { my ($self, $regex) = @_; my $usable_regex = undef; if( ref $regex eq 'Regexp' ) { $usable_regex = $regex; } # Check if it looks like '/foo/' elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { $usable_regex = length $opts ? "(?$opts)$re" : $re; }; return($usable_regex) }; sub _regex_ok { my($self, $this, $regex, $cmp, $name) = @_; local $Level = $Level + 1; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless (defined $usable_regex) { $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { local $^W = 0; my $test = $this =~ /$usable_regex/ ? 1 : 0; $test = !$test if $cmp eq '!~'; $ok = $self->ok( $test, $name ); } unless( $ok ) { $this = defined $this ? "'$this'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; $self->diag(sprintf < $Test->cmp_ok($this, $type, $that, $name); Works just like Test::More's cmp_ok(). $Test->cmp_ok($big_num, '!=', $other_big_num); =cut sub cmp_ok { my($self, $got, $type, $expect, $name) = @_; my $test; { local $^W = 0; local($@,$!); # don't interfere with $@ # eval() sometimes resets $! $test = eval "\$got $type \$expect"; } local $Level = $Level + 1; my $ok = $self->ok($test, $name); unless( $ok ) { if( $type =~ /^(eq|==)$/ ) { $self->_is_diag($got, $type, $expect); } else { $self->_cmp_diag($got, $type, $expect); } } return $ok; } sub _cmp_diag { my($self, $got, $type, $expect) = @_; $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; return $self->diag(sprintf < $Test->BAILOUT($reason); Indicates to the Test::Harness that things are going so badly all testing should terminate. This includes running any additional test scripts. It will exit with 255. =cut sub BAILOUT { my($self, $reason) = @_; $self->_print("Bail out! $reason"); exit 255; } =item B $Test->skip; $Test->skip($why); Skips the current test, reporting $why. =cut sub skip { my($self, $why) = @_; $why ||= ''; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => $why, ); $Test_Results[$Curr_Test-1] = \%result; my $out = "ok"; $out .= " $Curr_Test" if $self->use_numbers; $out .= " # skip $why\n"; $Test->_print($out); return 1; } =item B $Test->todo_skip; $Test->todo_skip($why); Like skip(), only it will declare the test as failing and TODO. Similar to print "not ok $tnum # TODO $why\n"; =cut sub todo_skip { my($self, $why) = @_; $why ||= ''; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, ); $Test_Results[$Curr_Test-1] = \%result; my $out = "not ok"; $out .= " $Curr_Test" if $self->use_numbers; $out .= " # TODO & SKIP $why\n"; $Test->_print($out); return 1; } =begin _unimplemented =item B $Test->skip_rest; $Test->skip_rest($reason); Like skip(), only it skips all the rest of the tests you plan to run and terminates the test. If you're running under no_plan, it skips once and terminates the test. =end _unimplemented =back =head2 Test style =over 4 =item B $Test->level($how_high); How far up the call stack should $Test look when reporting where the test failed. Defaults to 1. Setting $Test::Builder::Level overrides. This is typically useful localized: { local $Test::Builder::Level = 2; $Test->ok($test); } =cut sub level { my($self, $level) = @_; if( defined $level ) { $Level = $level; } return $Level; } $CLASS->level(1); =item B $Test->use_numbers($on_or_off); Whether or not the test should output numbers. That is, this if true: ok 1 ok 2 ok 3 or this if false ok ok ok Most useful when you can't depend on the test output order, such as when threads or forking is involved. Test::Harness will accept either, but avoid mixing the two styles. Defaults to on. =cut my $Use_Nums = 1; sub use_numbers { my($self, $use_nums) = @_; if( defined $use_nums ) { $Use_Nums = $use_nums; } return $Use_Nums; } =item B $Test->no_header($no_header); If set to true, no "1..N" header will be printed. =item B $Test->no_ending($no_ending); Normally, Test::Builder does some extra diagnostics when the test ends. It also changes the exit code as described in Test::Simple. If this is true, none of that will be done. =cut my($No_Header, $No_Ending) = (0,0); sub no_header { my($self, $no_header) = @_; if( defined $no_header ) { $No_Header = $no_header; } return $No_Header; } sub no_ending { my($self, $no_ending) = @_; if( defined $no_ending ) { $No_Ending = $no_ending; } return $No_Ending; } =back =head2 Output Controlling where the test output goes. It's ok for your test to change where STDOUT and STDERR point to, Test::Builder's default output settings will not be affected. =over 4 =item B $Test->diag(@msgs); Prints out the given $message. Normally, it uses the failure_output() handle, but if this is for a TODO test, the todo_output() handle is used. Output will be indented and marked with a # so as not to interfere with test output. A newline will be put on the end if there isn't one already. We encourage using this rather than calling print directly. Returns false. Why? Because diag() is often used in conjunction with a failing test (C) it "passes through" the failure. return ok(...) || diag(...); =for blame transfer Mark Fowler =cut sub diag { my($self, @msgs) = @_; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; # Escape each line with a #. foreach (@msgs) { $_ = 'undef' unless defined; s/^/# /gms; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; local $Level = $Level + 1; my $fh = $self->todo ? $self->todo_output : $self->failure_output; local($\, $", $,) = (undef, ' ', ''); print $fh @msgs; return 0; } =begin _private =item B<_print> $Test->_print(@msgs); Prints to the output() filehandle. =end _private =cut sub _print { my($self, @msgs) = @_; # Prevent printing headers when only compiling. Mostly for when # tests are deparsed with B::Deparse return if $^C; local($\, $", $,) = (undef, ' ', ''); my $fh = $self->output; # Escape each line after the first with a # so we don't # confuse Test::Harness. foreach (@msgs) { s/\n(.)/\n# $1/sg; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; print $fh @msgs; } =item B $Test->output($fh); $Test->output($file); Where normal "ok/not ok" test output should go. Defaults to STDOUT. =item B $Test->failure_output($fh); $Test->failure_output($file); Where diagnostic output on test failures and diag() should go. Defaults to STDERR. =item B $Test->todo_output($fh); $Test->todo_output($file); Where diagnostics about todo test failures and diag() should go. Defaults to STDOUT. =cut my($Out_FH, $Fail_FH, $Todo_FH); sub output { my($self, $fh) = @_; if( defined $fh ) { $Out_FH = _new_fh($fh); } return $Out_FH; } sub failure_output { my($self, $fh) = @_; if( defined $fh ) { $Fail_FH = _new_fh($fh); } return $Fail_FH; } sub todo_output { my($self, $fh) = @_; if( defined $fh ) { $Todo_FH = _new_fh($fh); } return $Todo_FH; } sub _new_fh { my($file_or_fh) = shift; my $fh; unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { $fh = do { local *FH }; open $fh, ">$file_or_fh" or die "Can't open test output log $file_or_fh: $!"; } else { $fh = $file_or_fh; } return $fh; } unless( $^C ) { # We dup STDOUT and STDERR so people can change them in their # test suites while still getting normal test output. open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. _autoflush(\*TESTOUT); _autoflush(\*STDOUT); _autoflush(\*TESTERR); _autoflush(\*STDERR); $CLASS->output(\*TESTOUT); $CLASS->failure_output(\*TESTERR); $CLASS->todo_output(\*TESTOUT); } sub _autoflush { my($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; } =back =head2 Test Status and Info =over 4 =item B my $curr_test = $Test->current_test; $Test->current_test($num); Gets/sets the current test # we're on. You usually shouldn't have to set this. =cut sub current_test { my($self, $num) = @_; lock($Curr_Test); if( defined $num ) { unless( $Have_Plan ) { require Carp; Carp::croak("Can't change the current test number without a plan!"); } $Curr_Test = $num; if( $num > @Test_Results ) { my $start = @Test_Results ? $#Test_Results + 1 : 0; for ($start..$num-1) { my %result; share(%result); %result = ( ok => 1, actual_ok => undef, reason => 'incrementing test number', type => 'unknown', name => undef ); $Test_Results[$_] = \%result; } } } return $Curr_Test; } =item B my @tests = $Test->summary; A simple summary of the tests so far. True for pass, false for fail. This is a logical pass/fail, so todos are passes. Of course, test #1 is $tests[0], etc... =cut sub summary { my($self) = shift; return map { $_->{'ok'} } @Test_Results; } =item B
my @tests = $Test->details; Like summary(), but with a lot more detail. $tests[$test_num - 1] = { 'ok' => is the test considered a pass? actual_ok => did it literally say 'ok'? name => name of the test (if any) type => type of test (if any, see below). reason => reason for the above (if any) }; 'ok' is true if Test::Harness will consider the test to be a pass. 'actual_ok' is a reflection of whether or not the test literally printed 'ok' or 'not ok'. This is for examining the result of 'todo' tests. 'name' is the name of the test. 'type' indicates if it was a special test. Normal tests have a type of ''. Type can be one of the following: skip see skip() todo see todo() todo_skip see todo_skip() unknown see below Sometimes the Test::Builder test counter is incremented without it printing any test output, for example, when current_test() is changed. In these cases, Test::Builder doesn't know the result of the test, so it's type is 'unkown'. These details for these tests are filled in. They are considered ok, but the name and actual_ok is left undef. For example "not ok 23 - hole count # TODO insufficient donuts" would result in this structure: $tests[22] = # 23 - 1, since arrays start from 0. { ok => 1, # logically, the test passed since it's todo actual_ok => 0, # in absolute terms, it failed name => 'hole count', type => 'todo', reason => 'insufficient donuts' }; =cut sub details { return @Test_Results; } =item B my $todo_reason = $Test->todo; my $todo_reason = $Test->todo($pack); todo() looks for a $TODO variable in your tests. If set, all tests will be considered 'todo' (see Test::More and Test::Harness for details). Returns the reason (ie. the value of $TODO) if running as todo tests, false otherwise. todo() is pretty part about finding the right package to look for $TODO in. It uses the exported_to() package to find it. If that's not set, it's pretty good at guessing the right package to look at. Sometimes there is some confusion about where todo() should be looking for the $TODO variable. If you want to be sure, tell it explicitly what $pack to use. =cut sub todo { my($self, $pack) = @_; $pack = $pack || $self->exported_to || $self->caller(1); no strict 'refs'; return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} : 0; } =item B my $package = $Test->caller; my($pack, $file, $line) = $Test->caller; my($pack, $file, $line) = $Test->caller($height); Like the normal caller(), except it reports according to your level(). =cut sub caller { my($self, $height) = @_; $height ||= 0; my @caller = CORE::caller($self->level + $height + 1); return wantarray ? @caller : $caller[0]; } =back =cut =begin _private =over 4 =item B<_sanity_check> _sanity_check(); Runs a bunch of end of test sanity checks to make sure reality came through ok. If anything is wrong it will die with a fairly friendly error message. =cut #'# sub _sanity_check { _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); _whoa(!$Have_Plan and $Curr_Test, 'Somehow your tests ran without a plan!'); _whoa($Curr_Test != @Test_Results, 'Somehow you got a different number of results than tests ran!'); } =item B<_whoa> _whoa($check, $description); A sanity check, similar to assert(). If the $check is true, something has gone horribly wrong. It will die with the given $description and a note to contact the author. =cut sub _whoa { my($check, $desc) = @_; if( $check ) { die < _my_exit($exit_num); Perl seems to have some trouble with exiting inside an END block. 5.005_03 and 5.6.1 both seem to do odd things. Instead, this function edits $? directly. It should ONLY be called from inside an END block. It doesn't actually exit, that's your job. =cut sub _my_exit { $? = $_[0]; return 1; } =back =end _private =cut $SIG{__DIE__} = sub { # We don't want to muck with death in an eval, but $^S isn't # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing # with it. Instead, we use caller. This also means it runs under # 5.004! my $in_eval = 0; for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { $in_eval = 1 if $sub =~ /^\(eval\)/; } $Test_Died = 1 unless $in_eval; }; sub _ending { my $self = shift; _sanity_check(); # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. do{ _my_exit($?) && return } if $Original_Pid != $$; # Bailout if plan() was never called. This is so # "require Test::Simple" doesn't puke. do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; # Figure out if we passed or failed and print helpful messages. if( @Test_Results ) { # The plan? We have no plan. if( $No_Plan ) { $self->_print("1..$Curr_Test\n") unless $self->no_header; $Expected_Tests = $Curr_Test; } # 5.8.0 threads bug. Shared arrays will not be auto-extended # by a slice. Worse, we have to fill in every entry else # we'll get an "Invalid value for shared scalar" error for my $idx ($#Test_Results..$Expected_Tests-1) { my %empty_result = (); share(%empty_result); $Test_Results[$idx] = \%empty_result unless defined $Test_Results[$idx]; } my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; $num_failed += abs($Expected_Tests - @Test_Results); if( $Curr_Test < $Expected_Tests ) { $self->diag(<<"FAIL"); Looks like you planned $Expected_Tests tests but only ran $Curr_Test. FAIL } elsif( $Curr_Test > $Expected_Tests ) { my $num_extra = $Curr_Test - $Expected_Tests; $self->diag(<<"FAIL"); Looks like you planned $Expected_Tests tests but ran $num_extra extra. FAIL } elsif ( $num_failed ) { $self->diag(<<"FAIL"); Looks like you failed $num_failed tests of $Expected_Tests. FAIL } if( $Test_Died ) { $self->diag(<<"FAIL"); Looks like your test died just after $Curr_Test. FAIL _my_exit( 255 ) && return; } _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; } elsif ( $Skip_All ) { _my_exit( 0 ) && return; } elsif ( $Test_Died ) { $self->diag(<<'FAIL'); Looks like your test died before it could output anything. FAIL } else { $self->diag("No tests run!\n"); _my_exit( 255 ) && return; } } END { $Test->_ending if defined $Test and !$Test->no_ending; } =head1 THREADS In perl 5.8.0 and later, Test::Builder is thread-safe. The test number is shared amongst all threads. This means if one thread sets the test number using current_test() they will all be effected. =head1 EXAMPLES CPAN can provide the best examples. Test::Simple, Test::More, Test::Exception and Test::Differences all use Test::Builder. =head1 SEE ALSO Test::Simple, Test::More, Test::Harness =head1 AUTHORS Original code by chromatic, maintained by Michael G Schwern Eschwern@pobox.comE =head1 COPYRIGHT Copyright 2002 by chromatic Echromatic@wgz.orgE, Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; More.pm000444000000000000 7467610573261145 16611 0ustar00unknownunknown000000000000Net-XMPP-1.02/t/lib/Testpackage Test::More; use 5.004; use strict; use Test::Builder; # Can't use Carp because it might cause use_ok() to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my($file, $line) = (caller(1))[1,2]; warn @_, " at $file line $line\n"; } require Exporter; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); $VERSION = '0.47'; @ISA = qw(Exporter); @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan can_ok isa_ok diag ); my $Test = Test::Builder->new; # 5.004's Exporter doesn't have export_to_level. sub _export_to_level { my $pkg = shift; my $level = shift; (undef) = shift; # redundant arg my $callpkg = caller($level); $pkg->export($callpkg, @_); } =head1 NAME Test::More - yet another framework for writing test scripts =head1 SYNOPSIS use Test::More tests => $Num_Tests; # or use Test::More qw(no_plan); # or use Test::More skip_all => $reason; BEGIN { use_ok( 'Some::Module' ); } require_ok( 'Some::Module' ); # Various ways to say "ok" ok($this eq $that, $test_name); is ($this, $that, $test_name); isnt($this, $that, $test_name); # Rather than print STDERR "# here's what went wrong\n" diag("here's what went wrong"); like ($this, qr/that/, $test_name); unlike($this, qr/that/, $test_name); cmp_ok($this, '==', $that, $test_name); is_deeply($complex_structure1, $complex_structure2, $test_name); SKIP: { skip $why, $how_many unless $have_some_feature; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; TODO: { local $TODO = $why; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; can_ok($module, @methods); isa_ok($object, $class); pass($test_name); fail($test_name); # Utility comparison functions. eq_array(\@this, \@that); eq_hash(\%this, \%that); eq_set(\@this, \@that); # UNIMPLEMENTED!!! my @status = Test::More::status; # UNIMPLEMENTED!!! BAIL_OUT($why); =head1 DESCRIPTION B If you're just getting started writing tests, have a look at Test::Simple first. This is a drop in replacement for Test::Simple which you can switch to once you get the hang of basic testing. The purpose of this module is to provide a wide range of testing utilities. Various ways to say "ok" with better diagnostics, facilities to skip tests, test future features and compare complicated data structures. While you can do almost anything with a simple C function, it doesn't provide good diagnostic output. =head2 I love it when a plan comes together Before anything else, you need a testing plan. This basically declares how many tests your script is going to run to protect against premature failure. The preferred way to do this is to declare a plan when you C. use Test::More tests => $Num_Tests; There are rare cases when you will not know beforehand how many tests your script is going to run. In this case, you can declare that you have no plan. (Try to avoid using this as it weakens your test.) use Test::More qw(no_plan); In some cases, you'll want to completely skip an entire testing script. use Test::More skip_all => $skip_reason; Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L for details. If you want to control what functions Test::More will export, you have to use the 'import' option. For example, to import everything but 'fail', you'd do: use Test::More tests => 23, import => ['!fail']; Alternatively, you can use the plan() function. Useful for when you have to calculate the number of tests. use Test::More; plan tests => keys %Stuff * 3; or for deciding between running the tests at all: use Test::More; if( $^O eq 'MacOS' ) { plan skip_all => 'Test irrelevant on MacOS'; } else { plan tests => 42; } =cut sub plan { my(@plan) = @_; my $caller = caller; $Test->exported_to($caller); my @imports = (); foreach my $idx (0..$#plan) { if( $plan[$idx] eq 'import' ) { my($tag, $imports) = splice @plan, $idx, 2; @imports = @$imports; last; } } $Test->plan(@plan); __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); } sub import { my($class) = shift; goto &plan; } =head2 Test names By convention, each test is assigned a number in order. This is largely done automatically for you. However, it's often very useful to assign a name to each test. Which would you rather see: ok 4 not ok 5 ok 6 or ok 4 - basic multi-variable not ok 5 - simple exponential ok 6 - force == mass * acceleration The later gives you some idea of what failed. It also makes it easier to find the test in your script, simply search for "simple exponential". All test functions take a name argument. It's optional, but highly suggested that you use it. =head2 I'm ok, you're not ok. The basic purpose of this module is to print out either "ok #" or "not ok #" depending on if a given test succeeded or failed. Everything else is just gravy. All of the following print "ok" or "not ok" depending on if the test succeeded or failed. They all also return true or false, respectively. =over 4 =item B ok($this eq $that, $test_name); This simply evaluates any expression (C<$this eq $that> is just a simple example) and uses that to determine if the test succeeded or failed. A true expression passes, a false one fails. Very simple. For example: ok( $exp{9} == 81, 'simple exponential' ); ok( Film->can('db_Main'), 'set_db()' ); ok( $p->tests == 4, 'saw tests' ); ok( !grep !defined $_, @items, 'items populated' ); (Mnemonic: "This is ok.") $test_name is a very short description of the test that will be printed out. It makes it very easy to find a test in your script when it fails and gives others an idea of your intentions. $test_name is optional, but we B strongly encourage its use. Should an ok() fail, it will produce some diagnostics: not ok 18 - sufficient mucus # Failed test 18 (foo.t at line 42) This is actually Test::Simple's ok() routine. =cut sub ok ($;$) { my($test, $name) = @_; $Test->ok($test, $name); } =item B =item B is ( $this, $that, $test_name ); isnt( $this, $that, $test_name ); Similar to ok(), is() and isnt() compare their two arguments with C and C respectively and use the result of that to determine if the test succeeded or failed. So these: # Is the ultimate answer 42? is( ultimate_answer(), 42, "Meaning of Life" ); # $foo isn't empty isnt( $foo, '', "Got some foo" ); are similar to these: ok( ultimate_answer() eq 42, "Meaning of Life" ); ok( $foo ne '', "Got some foo" ); (Mnemonic: "This is that." "This isn't that.") So why use these? They produce better diagnostics on failure. ok() cannot know what you are testing for (beyond the name), but is() and isnt() know what the test was and why it failed. For example this test: my $foo = 'waffle'; my $bar = 'yarblokos'; is( $foo, $bar, 'Is foo the same as bar?' ); Will produce something like this: not ok 17 - Is foo the same as bar? # Failed test (foo.t at line 139) # got: 'waffle' # expected: 'yarblokos' So you can figure out what went wrong without rerunning the test. You are encouraged to use is() and isnt() over ok() where possible, however do not be tempted to use them to find out if something is true or false! # XXX BAD! $pope->isa('Catholic') eq 1 is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' ); This does not check if C<$pope->isa('Catholic')> is true, it checks if it returns 1. Very different. Similar caveats exist for false and 0. In these cases, use ok(). ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' ); For those grammatical pedants out there, there's an C function which is an alias of isnt(). =cut sub is ($$;$) { $Test->is_eq(@_); } sub isnt ($$;$) { $Test->isnt_eq(@_); } *isn't = \&isnt; =item B like( $this, qr/that/, $test_name ); Similar to ok(), like() matches $this against the regex C. So this: like($this, qr/that/, 'this is like that'); is similar to: ok( $this =~ /that/, 'this is like that'); (Mnemonic "This is like that".) The second argument is a regular expression. It may be given as a regex reference (i.e. C) or (for better compatibility with older perls) as a string that looks like a regex (alternative delimiters are currently not supported): like( $this, '/that/', 'this is like that' ); Regex options may be placed on the end (C<'/that/i'>). Its advantages over ok() are similar to that of is() and isnt(). Better diagnostics on failure. =cut sub like ($$;$) { $Test->like(@_); } =item B unlike( $this, qr/that/, $test_name ); Works exactly as like(), only it checks if $this B match the given pattern. =cut sub unlike { $Test->unlike(@_); } =item B cmp_ok( $this, $op, $that, $test_name ); Halfway between ok() and is() lies cmp_ok(). This allows you to compare two arguments using any binary perl operator. # ok( $this eq $that ); cmp_ok( $this, 'eq', $that, 'this eq that' ); # ok( $this == $that ); cmp_ok( $this, '==', $that, 'this == that' ); # ok( $this && $that ); cmp_ok( $this, '&&', $that, 'this || that' ); ...etc... Its advantage over ok() is when the test fails you'll know what $this and $that were: not ok 1 # Failed test (foo.t at line 12) # '23' # && # undef It's also useful in those cases where you are comparing numbers and is()'s use of C will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); =cut sub cmp_ok($$$;$) { $Test->cmp_ok(@_); } =item B can_ok($module, @methods); can_ok($object, @methods); Checks to make sure the $module or $object can do these @methods (works with functions, too). can_ok('Foo', qw(this that whatever)); is almost exactly like saying: ok( Foo->can('this') && Foo->can('that') && Foo->can('whatever') ); only without all the typing and with a better interface. Handy for quickly testing an interface. No matter how many @methods you check, a single can_ok() call counts as one test. If you desire otherwise, use: foreach my $meth (@methods) { can_ok('Foo', $meth); } =cut sub can_ok ($@) { my($proto, @methods) = @_; my $class = ref $proto || $proto; unless( @methods ) { my $ok = $Test->ok( 0, "$class->can(...)" ); $Test->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { local($!, $@); # don't interfere with caller's $@ # eval sometimes resets $! eval { $proto->can($method) } || push @nok, $method; } my $name; $name = @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)"; my $ok = $Test->ok( !@nok, $name ); $Test->diag(map " $class->can('$_') failed\n", @nok); return $ok; } =item B isa_ok($object, $class, $object_name); isa_ok($ref, $type, $ref_name); Checks to see if the given $object->isa($class). Also checks to make sure the object was defined in the first place. Handy for this sort of thing: my $obj = Some::Module->new; isa_ok( $obj, 'Some::Module' ); where you'd otherwise have to write my $obj = Some::Module->new; ok( defined $obj && $obj->isa('Some::Module') ); to safeguard against your test script blowing up. It works on references, too: isa_ok( $array_ref, 'ARRAY' ); The diagnostics of this test normally just refer to 'the object'. If you'd like them to be more specific, you can supply an $object_name (for example 'Test customer'). =cut sub isa_ok ($$;$) { my($object, $class, $obj_name) = @_; my $diag; $obj_name = 'The object' unless defined $obj_name; my $name = "$obj_name isa $class"; if( !defined $object ) { $diag = "$obj_name isn't defined"; } elsif( !ref $object ) { $diag = "$obj_name isn't a reference"; } else { # We can't use UNIVERSAL::isa because we want to honor isa() overrides local($@, $!); # eval sometimes resets $! my $rslt = eval { $object->isa($class) }; if( $@ ) { if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { if( !UNIVERSAL::isa($object, $class) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } else { die <isa on your object and got some weird error. This should never happen. Please contact the author immediately. Here's the error. $@ WHOA } } elsif( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } my $ok; if( $diag ) { $ok = $Test->ok( 0, $name ); $Test->diag(" $diag\n"); } else { $ok = $Test->ok( 1, $name ); } return $ok; } =item B =item B pass($test_name); fail($test_name); Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to wedge into an ok(). In this case, you can simply use pass() (to declare the test ok) or fail (for not ok). They are synonyms for ok(1) and ok(0). Use these very, very, very sparingly. =cut sub pass (;$) { $Test->ok(1, @_); } sub fail (;$) { $Test->ok(0, @_); } =back =head2 Diagnostics If you pick the right test function, you'll usually get a good idea of what went wrong when it failed. But sometimes it doesn't work out that way. So here we have ways for you to write your own diagnostic messages which are safer than just C. =over 4 =item B diag(@diagnostic_message); Prints a diagnostic message which is guaranteed not to interfere with test output. Handy for this sort of thing: ok( grep(/foo/, @users), "There's a foo user" ) or diag("Since there's no foo, check that /etc/bar is set up right"); which would produce: not ok 42 - There's a foo user # Failed test (foo.t at line 52) # Since there's no foo, check that /etc/bar is set up right. You might remember C with the mnemonic C. B The exact formatting of the diagnostic output is still changing, but it is guaranteed that whatever you throw at it it won't interfere with the test. =cut sub diag { $Test->diag(@_); } =back =head2 Module tests You usually want to test if the module you're testing loads ok, rather than just vomiting if its load fails. For such purposes we have C and C. =over 4 =item B BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } These simply use the given $module and test to make sure the load happened ok. It's recommended that you run use_ok() inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. If @imports are given, they are passed through to the use. So this: BEGIN { use_ok('Some::Module', qw(foo bar)) } is like doing this: use Some::Module qw(foo bar); don't try to do this: BEGIN { use_ok('Some::Module'); ...some code that depends on the use... ...happening at compile time... } instead, you want: BEGIN { use_ok('Some::Module') } BEGIN { ...some code that depends on the use... } =cut sub use_ok ($;@) { my($module, @imports) = @_; @imports = () unless @imports; my $pack = caller; local($@,$!); # eval sometimes interferes with $! eval <import(\@imports); USE my $ok = $Test->ok( !$@, "use $module;" ); unless( $ok ) { chomp $@; $Test->diag(< require_ok($module); Like use_ok(), except it requires the $module. =cut sub require_ok ($) { my($module) = shift; my $pack = caller; local($!, $@); # eval sometimes interferes with $! eval <ok( !$@, "require $module;" ); unless( $ok ) { chomp $@; $Test->diag(<. The way Test::More handles this is with a named block. Basically, a block of tests which can be skipped over or made todo. It's best if I just show you... =over 4 =item B SKIP: { skip $why, $how_many if $condition; ...normal testing code goes here... } This declares a block of tests that might be skipped, $how_many tests there are, $why and under what $condition to skip them. An example is the easiest way to illustrate: SKIP: { eval { require HTML::Lint }; skip "HTML::Lint not installed", 2 if $@; my $lint = new HTML::Lint; isa_ok( $lint, "HTML::Lint" ); $lint->parse( $html ); is( $lint->errors, 0, "No errors found in HTML" ); } If the user does not have HTML::Lint installed, the whole block of code I. Test::More will output special ok's which Test::Harness interprets as skipped, but passing, tests. It's important that $how_many accurately reflects the number of tests in the SKIP block so the # of tests run will match up with your plan. It's perfectly safe to nest SKIP blocks. Each SKIP block must have the label C, or Test::More can't work its magic. You don't skip tests which are failing because there's a bug in your program, or for which you don't yet have code written. For that you use TODO. Read on. =cut #'# sub skip { my($why, $how_many) = @_; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "skip() needs to know \$how_many tests are in the block" unless $Test::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { $Test->skip($why); } local $^W = 0; last SKIP; } =item B TODO: { local $TODO = $why if $condition; ...normal testing code goes here... } Declares a block of tests you expect to fail and $why. Perhaps it's because you haven't fixed a bug or haven't finished a new feature: TODO: { local $TODO = "URI::Geller not finished"; my $card = "Eight of clubs"; is( URI::Geller->your_card, $card, 'Is THIS your card?' ); my $spoon; URI::Geller->bend_spoon; is( $spoon, 'bent', "Spoon bending, that's original" ); } With a todo block, the tests inside are expected to fail. Test::More will run the tests normally, but print out special flags indicating they are "todo". Test::Harness will interpret failures as being ok. Should anything succeed, it will report it as an unexpected success. You then know the thing you had todo is done and can remove the TODO flag. The nice part about todo tests, as opposed to simply commenting out a block of tests, is it's like having a programmatic todo list. You know how much work is left to be done, you're aware of what bugs there are, and you'll know immediately when they're fixed. Once a todo test starts succeeding, simply move it outside the block. When the block is empty, delete it. =item B TODO: { todo_skip $why, $how_many if $condition; ...normal testing code... } With todo tests, it's best to have the tests actually run. That way you'll know when they start passing. Sometimes this isn't possible. Often a failing test will cause the whole program to die or hang, even inside an C with and using C. In these extreme cases you have no choice but to skip over the broken tests entirely. The syntax and behavior is similar to a C except the tests will be marked as failing but todo. Test::Harness will interpret them as passing. =cut sub todo_skip { my($why, $how_many) = @_; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $Test::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { $Test->todo_skip($why); } local $^W = 0; last TODO; } =item When do I use SKIP vs. TODO? B, use SKIP. This includes optional modules that aren't installed, running under an OS that doesn't have some feature (like fork() or symlinks), or maybe you need an Internet connection and one isn't available. B, use TODO. This is for any code you haven't written yet, or bugs you have yet to fix, but want to put tests in your testing script (always a good idea). =back =head2 Comparison functions Not everything is a simple eq check or regex. There are times you need to see if two arrays are equivalent, for instance. For these instances, Test::More provides a handful of useful functions. B These are NOT well-tested on circular references. Nor am I quite sure what will happen with filehandles. =over 4 =item B is_deeply( $this, $that, $test_name ); Similar to is(), except that if $this and $that are hash or array references, it does a deep comparison walking each data structure to see if they are equivalent. If the two structures are different, it will display the place where they start differing. Barrie Slaymaker's Test::Differences module provides more in-depth functionality along these lines, and it plays well with Test::More. B Display of scalar refs is not quite 100% =cut use vars qw(@Data_Stack); my $DNE = bless [], 'Does::Not::Exist'; sub is_deeply { my($this, $that, $name) = @_; my $ok; if( !ref $this || !ref $that ) { $ok = $Test->is_eq($this, $that, $name); } else { local @Data_Stack = (); if( _deep_check($this, $that) ) { $ok = $Test->ok(1, $name); } else { $ok = $Test->ok(0, $name); $ok = $Test->diag(_format_stack(@Data_Stack)); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{$Stack[-1]{vals}}[0,1]; my @vars = (); ($vars[0] = $var) =~ s/\$FOO/ \$got/; ($vars[1] = $var) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx (0..$#vals) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : $val eq $DNE ? "Does not exist" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } =item B eq_array(\@this, \@that); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. =cut #'# sub eq_array { my($a1, $a2) = @_; return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for (0..$max) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; $ok = _deep_check($e1,$e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _deep_check { my($e1, $e2) = @_; my $ok = 0; my $eq; { # Quiet uninitialized value warnings when comparing undefs. local $^W = 0; if( $e1 eq $e2 ) { $ok = 1; } else { if( UNIVERSAL::isa($e1, 'ARRAY') and UNIVERSAL::isa($e2, 'ARRAY') ) { $ok = eq_array($e1, $e2); } elsif( UNIVERSAL::isa($e1, 'HASH') and UNIVERSAL::isa($e2, 'HASH') ) { $ok = eq_hash($e1, $e2); } elsif( UNIVERSAL::isa($e1, 'REF') and UNIVERSAL::isa($e2, 'REF') ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } elsif( UNIVERSAL::isa($e1, 'SCALAR') and UNIVERSAL::isa($e2, 'SCALAR') ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); } else { push @Data_Stack, { vals => [$e1, $e2] }; $ok = 0; } } } return $ok; } =item B eq_hash(\%this, \%that); Determines if the two hashes contain the same keys and values. This is a deep check. =cut sub eq_hash { my($a1, $a2) = @_; return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k (keys %$bigger) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; $ok = _deep_check($e1, $e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } =item B eq_set(\@this, \@that); Similar to eq_array(), except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. B By historical accident, this is not a true set comparision. While the order of elements does not matter, duplicate elements do. =cut # We must make sure that references are treated neutrally. It really # doesn't matter how we sort them, as long as both arrays are sorted # with the same algorithm. sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b } sub eq_set { my($a1, $a2) = @_; return 0 unless @$a1 == @$a2; # There's faster ways to do this, but this is easiest. return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); } =back =head2 Extending and Embedding Test::More Sometimes the Test::More interface isn't quite enough. Fortunately, Test::More is built on top of Test::Builder which provides a single, unified backend for any test library to use. This means two test libraries which both use Test::Builder B. If you simply want to do a little tweaking of how the tests behave, you can access the underlying Test::Builder object like so: =over 4 =item B my $test_builder = Test::More->builder; Returns the Test::Builder object underlying Test::More for you to play with. =cut sub builder { return Test::Builder->new; } =back =head1 NOTES Test::More is B tested all the way back to perl 5.004. Test::More is thread-safe for perl 5.8.0 and up. =head1 BUGS and CAVEATS =over 4 =item Making your own ok() If you are trying to extend Test::More, don't. Use Test::Builder instead. =item The eq_* family has some caveats. =item Test::Harness upgrades no_plan and todo depend on new Test::Harness features and fixes. If you're going to distribute tests that use no_plan or todo your end-users will have to upgrade Test::Harness to the latest one on CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness will work fine. If you simply depend on Test::More, it's own dependencies will cause a Test::Harness upgrade. =back =head1 HISTORY This is a case of convergent evolution with Joshua Pritikin's Test module. I was largely unaware of its existence when I'd first written my own ok() routines. This module exists because I can't figure out how to easily wedge test names into Test's interface (along with a few other problems). The goal here is to have a testing utility that's simple to learn, quick to use and difficult to trip yourself up with while still providing more flexibility than the existing Test.pm. As such, the names of the most common routines are kept tiny, special cases and magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO L if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (it's forward compatible). L for more ways to test complex data structures. And it plays well with Test::More. L is the old testing module. Its main benefit is that it has been distributed with Perl since 5.004_05. L for details on how your test results are interpreted by Perl. L describes a very featureful unit testing interface. L shows the idea of embedded testing. L is another approach to embedded testing. =head1 AUTHORS Michael G Schwern Eschwern@pobox.comE with much inspiration from Joshua Pritikin's Test module and lots of help from Barrie Slaymaker, Tony Bowden, chromatic and the perl-qa gang. =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; Simple.pm000444000000000000 1456510573261145 17127 0ustar00unknownunknown000000000000Net-XMPP-1.02/t/lib/Testpackage Test::Simple; use 5.004; use strict 'vars'; use vars qw($VERSION); $VERSION = '0.47'; use Test::Builder; my $Test = Test::Builder->new; sub import { my $self = shift; my $caller = caller; *{$caller.'::ok'} = \&ok; $Test->exported_to($caller); $Test->plan(@_); } =head1 NAME Test::Simple - Basic utilities for writing tests. =head1 SYNOPSIS use Test::Simple tests => 1; ok( $foo eq $bar, 'foo is bar' ); =head1 DESCRIPTION ** If you are unfamiliar with testing B first! ** This is an extremely simple, extremely basic module for writing tests suitable for CPAN modules and other pursuits. If you wish to do more complicated testing, use the Test::More module (a drop-in replacement for this one). The basic unit of Perl testing is the ok. For each thing you want to test your program will print out an "ok" or "not ok" to indicate pass or fail. You do this with the ok() function (see below). The only other constraint is you must pre-declare how many tests you plan to run. This is in case something goes horribly wrong during the test and your test program aborts, or skips a test or whatever. You do this like so: use Test::Simple tests => 23; You must have a plan. =over 4 =item B ok( $foo eq $bar, $name ); ok( $foo eq $bar ); ok() is given an expression (in this case C<$foo eq $bar>). If it's true, the test passed. If it's false, it didn't. That's about it. ok() prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). # This produces "ok 1 - Hell not yet frozen over" (or not ok) ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand what your test is for. It's highly recommended you use test names. All tests are run in scalar context. So this: ok( @stuff, 'I have some stuff' ); will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { $Test->ok(@_); } =back Test::Simple will start by printing number of tests run in the form "1..M" (so "1..5" means you're going to run 5 tests). This strange format lets Test::Harness know how many tests you plan on running in case something goes horribly wrong. If all your tests passed, Test::Simple will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Simple will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. This module is by no means trying to be a complete testing system. It's just to get you started. Once you're off the ground its recommended you look at L. =head1 EXAMPLE Here's an example of a simple .t file for the fictional Film module. use Test::Simple tests => 5; use Film; # What you're testing. my $btaste = Film->new({ Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1 }); ok( defined($btaste) and ref $btaste eq 'Film', 'new() works' ); ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); ok( $btaste->Rating eq 'R', 'Rating() get' ); ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); It will produce output like this: 1..5 ok 1 - new() works ok 2 - Title() get ok 3 - Director() get not ok 4 - Rating() get # Failed test (t/film.t at line 14) ok 5 - NumExplodingSheep() get # Looks like you failed 1 tests of 5 Indicating the Film::Rating() method is broken. =head1 CAVEATS Test::Simple will only report a maximum of 254 failures in its exit code. If this is a problem, you probably have a huge test script. Split it into multiple files. (Otherwise blame the Unix folks for using an unsigned short integer as the exit status). Because VMS's exit codes are much, much different than the rest of the universe, and perl does horrible mangling to them that gets in my way, it works like this on VMS. 0 SS$_NORMAL all tests successful 4 SS$_ABORT something went wrong Unfortunately, I can't differentiate any further. =head1 NOTES Test::Simple is B tested all the way back to perl 5.004. Test::Simple is thread-safe in perl 5.8.0 and up. =head1 HISTORY This module was conceived while talking with Tony Bowden in his kitchen one night about the problems I was having writing some really complicated feature into the new Testing module. He observed that the main problem is not dealing with these edge cases but that people hate to write tests B. What was needed was a dead simple module that took all the hard work out of testing and was really, really easy to learn. Paul Johnson simultaneously had this idea (unfortunately, he wasn't in Tony's kitchen). This is it. =head1 SEE ALSO =over 4 =item L More testing functions! Once you outgrow Test::Simple, look at Test::More. Test::Simple is 100% forward compatible with Test::More (i.e. you can just use Test::More instead of Test::Simple in your programs and things will still work). =item L The original Perl testing module. =item L Elaborate unit testing. =item L, L Embed tests in your code! =item L Interprets the output of your test program. =back =head1 AUTHORS Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern Eschwern@pobox.comE, wardrobe by Calvin Klein. =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1;