Net-XMPP-1.05000755001750001750 012446106423 14040 5ustar00dapatrickdapatrick000000000000Net-XMPP-1.05/META.yml000444001750001750 271512446106423 15453 0ustar00dapatrickdapatrick000000000000--- abstract: 'XMPP Support Library' author: - 'Darian Anthony Patrick ' build_requires: LWP::Online: '1.07' Test::More: '0.92' YAML::Tiny: '1.41' configure_requires: Module::Build: '0.360300' dynamic_config: 1 generated_by: 'Module::Build version 0.4205, CPAN::Meta::Converter version 2.141170' license: lgpl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Net-XMPP provides: Net::XMPP: file: lib/Net/XMPP.pm version: '1.05' 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 requires: Authen::SASL: '2.12' Digest::SHA: '0' Scalar::Util: '0' XML::Stream: '1.24' perl: v5.8.0 resources: bugtracker: https://github.com/dap/Net-XMPP/issues license: http://www.gnu.org/licenses/old-licenses/lgpl-2.1.txt repository: https://github.com/dap/Net-XMPP version: '1.05' Net-XMPP-1.05/README000444001750001750 120612446106423 15054 0ustar00dapatrickdapatrick000000000000Net::XMPP 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. Please report bugs at https://github.com/dap/Net-XMPP/issues. Net-XMPP-1.05/MANIFEST000444001750001750 147312446106423 15333 0ustar00dapatrickdapatrick000000000000Build.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 Makefile.PL MANIFEST This list of files META.yml README t/1_load.t t/2_client_jabberd1.4.t t/3_client_jabberd2.t t/config/accounts.yml.copyme t/get_time_stamp.test t/gtalk.t t/iq.t t/jid.t t/lib/Net/XMPP/Test/Utils.pm t/memory_cycle.t t/memory_leak.t 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 t/srv.t META.json SIGNATURE Added here by Module::Build Net-XMPP-1.05/Makefile.PL000444001750001750 44712446106423 16134 0ustar00dapatrickdapatrick000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4205 require 5.008000; use Module::Build::Compat 0.02; Module::Build::Compat->run_build_pl(args => \@ARGV); require Module::Build; Module::Build::Compat->write_makefile(build_class => 'Module::Build'); Net-XMPP-1.05/LICENSE000444001750001750 6016012446106423 15225 0ustar00dapatrickdapatrick000000000000This software is Copyright (c) 2014 by Darian Anthony Patrick . This is free software, licensed under: The GNU Lesser General Public License, Version 2.1, February 1999 The GNU Lesser General Public License (LGPL) Version 2.1, February 1999 (The master copy of this license lives on the GNU website.) Copyright (C) 1991, 1999 Free Software Foundation, Inc. 59 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] 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 Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, 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 and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these 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 other code 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. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. 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, whereas the latter must be combined with the library in order to run. TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser 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 combine 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) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) 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. d) 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. e) 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 materials to be 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 with 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 Lesser 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 Net-XMPP-1.05/META.json000444001750001750 450312446106423 15620 0ustar00dapatrickdapatrick000000000000{ "abstract" : "XMPP Support Library", "author" : [ "Darian Anthony Patrick " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4205", "license" : [ "lgpl_2_1" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Net-XMPP", "prereqs" : { "build" : { "requires" : { "LWP::Online" : "1.07", "Test::More" : "0.92", "YAML::Tiny" : "1.41" } }, "configure" : { "requires" : { "Module::Build" : "0.360300" } }, "runtime" : { "requires" : { "Authen::SASL" : "2.12", "Digest::SHA" : "0", "Scalar::Util" : "0", "XML::Stream" : "1.24", "perl" : "v5.8.0" } } }, "provides" : { "Net::XMPP" : { "file" : "lib/Net/XMPP.pm", "version" : "1.05" }, "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" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/dap/Net-XMPP/issues" }, "license" : [ "http://www.gnu.org/licenses/old-licenses/lgpl-2.1.txt" ], "repository" : { "url" : "https://github.com/dap/Net-XMPP" } }, "version" : "1.05" } Net-XMPP-1.05/Build.PL000444001750001750 152612446106423 15475 0ustar00dapatrickdapatrick000000000000use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'Net::XMPP', license => 'lgpl', dist_author => 'Darian Anthony Patrick ', dist_abstract => 'XMPP Support Library', configure_requires => { 'Module::Build' => '0.360300', }, build_requires => { 'LWP::Online' => '1.07', 'Test::More' => '0.92', 'YAML::Tiny' => '1.41', }, requires => { 'perl' => 'v5.8.0', 'Authen::SASL' => '2.12', 'Digest::SHA' => '0', 'XML::Stream' => '1.24', 'Scalar::Util' => '0', }, sign => 1, create_license => 1, create_makefile_pl => 'small', meta_merge => { 'resources' => { 'bugtracker' => 'https://github.com/dap/Net-XMPP/issues', 'repository' => 'https://github.com/dap/Net-XMPP', } }, ); $build->create_build_script(); Net-XMPP-1.05/CHANGES000444001750001750 632412446106423 15175 0ustar00dapatrickdapatrick0000000000001.05 2014-12-22 ==== - Update CHANGES file 1.04 2014-12-22 ==== - Increase XML::Stream dependency to 1.24 1.03 2014-12-22 ==== - Roll-up of all 1.02_* changes - Update bug tracker location - RT#94649 use Digest::SHA (from Debian package maintainers) - RT#94650 spelling corrections (from Debian package maintainers) 1.02_05 2014-12-17 ==== - Correct incorrectly tagged 1.02_04 (errantly tagged as 1.23_04) - Remove extraneous tag 1.02_1 (1.02_01 points to the same content) 1.02_04 2011-07-19 === - Remove outdated Test::More/Test::Builder (szabgab) - Address more memory leaks in Net::XMPP::Connection, Net::XMPP::Protocol and Net::XMPP::Roster (szabgab) - Fix crash connecting to Google Talk (szabgab) - Add Google Talk-specific test (szabgab) - Add memory leak tests (szabgab) - Correct behavior of Net::XMPP::Debug when level >= 0 (szabgab) - Correct documentation with regard to debug settings (szabgab) - Correct required version of Perl (szabgab) - Removed specific XML::Stream version require (szabgab) 1.02_03 2011-06-23 === - RT#61611 Correct comparison operator - Fixed memory leak in Net::XMPP::Connection (szabgab) - RT#52549 unindented POD so that it reformats properly (szabgab) - Replace indirect object notation with direct invocation notation (szabgab) 1.02_02 2010-09-24 === - Increase XML::Stream dependency to 1.23_04 1.02_01 2010-09-22 === - New maintainer: DAPATRICK - RT#15736 Replace print statements to debug logging - RT#51156 Correct typo in documentation - RT#54521 Note dependency on XML::Stream 1.23 - RT#37129, RT#18539 Support for virtual domains - RT#57887 Use each required module explicitly - RT#61453 Pass ssl_verify and ssl_ca_path - RT#61453 Improve undef/null ssl param handling - RT#61144 Appropriately handle non-object jid - RT#37030 Clarify license as LGPL 2.1 - RT#58333 Check definedness of hash key before use 1.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. Net-XMPP-1.05/SIGNATURE000644001750001750 673612446106423 15477 0ustar00dapatrickdapatrick000000000000This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.73. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 df9d4478aeb0726067e89c0b39e60fde144c9bfe Build.PL SHA1 31e9fe9e820b299bc1ad886bb8b2f9a5bc6fed1c CHANGES SHA1 e6382a2e4814837e0034b5b1fe6338d75068d7d8 LICENSE SHA1 9dce84efce5fa18537493b026406ba3f739c922d MANIFEST SHA1 893b592a8af5a75037f11a994f002dec7af86e89 META.json SHA1 99033f62f6906298044b114d52d38f08ebf3c8d8 META.yml SHA1 f6cdc9aca2ed3ed3025087acf96b8d24f89201fc Makefile.PL SHA1 7b62eb1f834045c9b03ade44efe90defce468357 README SHA1 56395324555c66964ac300f097d53c7282d3f884 examples/client.pl SHA1 4b002e8a47b1bd44d23847d9a2d0e6b1c06b62de examples/client_xpath.pl SHA1 c16b8372dbd21757991558632960eb7aa3c89970 lib/Net/XMPP.pm SHA1 20768db079f852d6161481455e7ccda70f746b7c lib/Net/XMPP/Client.pm SHA1 8e7431d2eb112107a3dcd70a2cabf43f7b9e84c8 lib/Net/XMPP/Connection.pm SHA1 047479b19cbf74d2ffead46ebdff4ec2e3e35598 lib/Net/XMPP/Debug.pm SHA1 ac1c71245bc41fb700c06d49de1bd3358ad7fd55 lib/Net/XMPP/IQ.pm SHA1 98db8b388f3340e789abfa59fdf24d771ee60555 lib/Net/XMPP/JID.pm SHA1 bdf3c970ef371d735d1271854bee99b12cb74320 lib/Net/XMPP/Message.pm SHA1 ffd4e9eadc6fcffd4a1788886093a2c107a5b89e lib/Net/XMPP/Namespaces.pm SHA1 6f4bfbf898a3743cd64ac8db9ec13c368c3d4ef1 lib/Net/XMPP/Presence.pm SHA1 c794b060f0e30325c1b3794743078d416b2c5792 lib/Net/XMPP/PrivacyLists.pm SHA1 9ccf9aa64258a1467868601c9fbb024076eaca54 lib/Net/XMPP/Protocol.pm SHA1 347303c860125d6cd3044d6fa6ba93cf4b2f9f3f lib/Net/XMPP/Roster.pm SHA1 91bb321744c1b53e7a371968ae732574dd7cfb8c lib/Net/XMPP/Stanza.pm SHA1 dadd2326dfff4d22dfc4870c672fd31a40dd86a8 t/1_load.t SHA1 b73dea8a5cd1bfbf15e3e8dfc2ea72a6c00bfa70 t/2_client_jabberd1.4.t SHA1 272852577847d66285daf113464f8594acea747b t/3_client_jabberd2.t SHA1 4dc9cd2d74671e7e256e6b3f8fd29725e1231c10 t/config/accounts.yml.copyme SHA1 176c999052912127b3b36cf3ec5b29af4721cb79 t/get_time_stamp.test SHA1 89dfece07866a72994f3760755d0c7b40e72f42f t/gtalk.t SHA1 132f93f7d927f6d5528cdb36b10e91474e0a02ac t/iq.t SHA1 e006af61529ff08cb8056ab114de7714a7e4a2e5 t/jid.t SHA1 a2de64e34bcf7eff51de3ef7998ce9710e8464b3 t/lib/Net/XMPP/Test/Utils.pm SHA1 e0dc5181e62285604bffb1d927b1c236ec3c92b9 t/memory_cycle.t SHA1 c1409d356ef5676ce8a7b2bc07a11f93089d9492 t/memory_leak.t SHA1 98e773d39e9c37ac09405e3923c1a97e16ca4ebe t/message.t SHA1 98c5a88b61cc930673c10731ab593323a8f2c0bc t/mytestlib.pl SHA1 47132a054b2bfd16ee7ca7c06741993bbbaebc88 t/node1.xml SHA1 50688b8dbfd86affd8c51e039df302440a89c597 t/node2.xml SHA1 f2ce8c701b89f828a042359b1653afe8c36c752b t/packet_iqauth.t SHA1 ce91609b363af5b7bdcb7b283d1eec2a43c83e0c t/packet_iqroster.t SHA1 12072726e79263ce927989c778bf895b11344641 t/presence.t SHA1 5950e466154e233344d0d0c86a69dfa19f3957af t/query_xxxxx.test SHA1 e1c0f8a99820422f6447eae77520656640230083 t/rawxml.t SHA1 fa5ed330ecc053f017cc75fc648b51e139b03ff9 t/roster.t SHA1 21ab9a1fb1118bc7331bbae053fd479d47838cf2 t/srv.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1 iEYEARECAAYFAlSYjRMACgkQjJ7fFJrTQRfygQCdEoTJnZncBq0rghmjq1pgzaoI 1AgAn1Nu0PgulGi8WSfxt9VSEpZoKo8J =fV2v -----END PGP SIGNATURE----- Net-XMPP-1.05/examples000755001750001750 012446106423 15656 5ustar00dapatrickdapatrick000000000000Net-XMPP-1.05/examples/client_xpath.pl000444001750001750 542612446106423 21041 0ustar00dapatrickdapatrick000000000000 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"; } Net-XMPP-1.05/examples/client.pl000444001750001750 536312446106423 17635 0ustar00dapatrickdapatrick000000000000 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"; } Net-XMPP-1.05/t000755001750001750 012446106423 14303 5ustar00dapatrickdapatrick000000000000Net-XMPP-1.05/t/gtalk.t000444001750001750 1320412446106423 15747 0ustar00dapatrickdapatrick000000000000use strict; use warnings; use Test::More; ######################## XML::Stream mocking starts #{ # package XML::Stream; # our $AUTOLOAD; # use Data::Dumper; # # sub new { # bless {}, shift; # } # sub Connect { # } # sub GetErrorCode { # } # sub GetStreamFeature { # } # sub SASLClient { # } # DESTROY { # } # # AUTOLOAD { # print Dumper [$AUTOLOAD, \@_]; # } # #} #$INC{'XML/Stream.pm'} = 1; ######################## XML::Stream mocking ends my @users; foreach my $name (qw(GTALK0 GTALK1)) { if ($ENV{$name}) { my ($user, $pw) = split /:/, $ENV{$name}; push @users, { username => $user, password => $pw, }; } } eval "use Test::Memory::Cycle"; my $memory_cycle = ! $@; my $leak_guard; BEGIN { eval "use Devel::LeakGuard::Object qw(leakguard)"; $leak_guard = ! $@; } my $repeat = 5; plan tests => 2 + 6 * $repeat; # TODO ask user if it is ok to do network tests! print_size('before loading Net::XMPP'); require Net::XMPP; print_size('after loading Net::XMPP'); # see # http://blogs.perl.org/users/marco_fontani/2010/03/google-talk-with-perl.html { # monkey-patch XML::Stream to support the google-added JID package XML::Stream; no warnings 'redefine'; sub SASLAuth { my $self = shift; my $sid = shift; my $first_step = $self->{SIDS}->{$sid}->{sasl}->{client}->client_start(); my $first_step64 = MIME::Base64::encode_base64( $first_step, "" ); $self->Send( $sid, "" . $first_step64 . "" ); } } my $mem1 = run(); my $mem_last = $mem1; for (2..$repeat) { $mem_last = run(); } # The leakage shown here happens even before Authentication is called #SKIP: { # skip 'Devel::LeakGuard::Object is needed', 1 if not $leak_guard; # my $warn; # local $SIG{__WARN__} = sub { $warn = shift }; # leakguard { # run(); # }; # # ok(!$warn, 'leaking') or diag $warn; #} # as I can see setting up the connection leaks in the first 5 attempts # and then it stops leaking. I tried it with repeate=25 # When adding AuthSend to the mix the code keeps leaking even after 20 repeats. # Still the total leak is only 130 in 25 repeats # After duplicating the connections (having two users), # adding the CallBacks and handling the presence messages. # the leak after 25 repeats went up to 152. # # This might need to be added to a test case. # For now we only check if it "does not leak too much" diag 'Memory change: ' . ($mem_last - $mem1); TODO: { local $TODO = 'Memory leak or expectations being to high?'; is $mem_last, $mem1, 'expected 0 memory growth'; } cmp_ok $mem_last, '<', $mem1+160, 'does not leak much' or diag 'Leak: ' . ($mem_last-$mem1); # tools when XML::Stream mocking #use Data::Dumper; #die Dumper \%INC; #foreach my $k (keys %INC) { # if ($k =~ m{XML}) { # diag $k; # } #} # end tools exit; sub run { my @conn; for my $i (0,1) { $conn[$i] = Net::XMPP::Client->new; isa_ok $conn[$i], 'Net::XMPP::Client'; my $status = $conn[$i]->Connect( hostname => 'talk.google.com', port => 5222, componentname => 'gmail.com', connectiontype => 'tcpip', tls => 1, ssl_verify => 0, ); SKIP: { skip 'Needs Test::Memory::Cycle', 1 if not $memory_cycle; memory_cycle_ok($conn[$i], 'after calling Connect'); } SKIP: { skip "need GTALK$i = username:password", 1 if not $users[$i]; my ( $res, $msg ) = $conn[$i]->AuthSend( username => $users[$i]{username}, password => $users[$i]{password}, resource => 'notify v1.0', ); is $res, 'ok', 'result is ok'; if (not defined $res or $res ne 'ok') { diag $!; } $conn[$i]->SetCallBacks( message => \&on_message, presence => \&on_presence, receive => \&on_receive, ); $conn[$i]->PresenceSend(); } } for my $i (0..5) { my $status = $conn[$i % 2]->Process(1); die if not defined $status; } # receive presence message # send and receive messages return print_size('after calling Run'); } sub print_size { my ($msg) = @_; return 0 if not -x '/bin/ps'; my @lines = grep { /^$$\s/ } qx{/bin/ps -e -o pid,rss,command}; chomp @lines; my $RSS; foreach my $line (@lines) { my ($pid, $rss) = split /\s+/, $line; diag "RSS: $rss - $msg"; $RSS = $rss; } return $RSS; } sub on_presence { my ($sid, $presence) = @_; my $to = $presence->GetTo; my $from = $presence->GetFrom; my $type = $presence->GetType || 'available'; my $status = $presence->GetStatus || ''; ($to) = split m{/}, $to; ($from) = split m{/}, $from; diag "$to - $from - $type - $status"; } sub on_receive { # called on every message received } sub on_message { my ($message) = @_; my $type = $message->GetType; my $fromJID = $message->fromJID('jid'); my $from = $message->GetUserID; my $resource = $message->GetResource; my $subject = $message->GetSubject; my $body = $message->GetBody; my $xml = $message->GetXML; diag "$from - $body"; } Net-XMPP-1.05/t/mytestlib.pl000444001750001750 725712446106423 17024 0ustar00dapatrickdapatrick000000000000 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; Net-XMPP-1.05/t/iq.t000444001750001750 1422512446106423 15262 0ustar00dapatrickdapatrick000000000000#use lib "t/lib"; use Test::More tests=>115; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = Net::XMPP::Debug->new(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); #------------------------------------------------------------------------------ # iq #------------------------------------------------------------------------------ my $iq = Net::XMPP::IQ->new(); 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 = Net::XMPP::IQ->new(); 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"); Net-XMPP-1.05/t/message.t000444001750001750 1477512446106423 16307 0ustar00dapatrickdapatrick000000000000use lib "t/lib"; use Test::More tests=>136; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = Net::XMPP::Debug->new(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); #------------------------------------------------------------------------------ # message #------------------------------------------------------------------------------ my $message = Net::XMPP::Message->new(); 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 = Net::XMPP::Message->new(); 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"); Net-XMPP-1.05/t/2_client_jabberd1.4.t000444001750001750 553612446106423 20231 0ustar00dapatrickdapatrick000000000000use 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 = Net::XMPP::Client->new(); $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); } Net-XMPP-1.05/t/srv.t000444001750001750 276712446106423 15453 0ustar00dapatrickdapatrick000000000000 use lib 't/lib'; use strict; use warnings; use Test::More tests => '7'; use Net::XMPP::Test::Utils qw/ can_run_tests get_conn_params get_auth_params bare_jid /; BEGIN { use_ok('Net::XMPP'); } SKIP: { skip "No accounts configured in $Net::XMPP::Test::Utils::accounts_file", 6 unless can_run_tests(); my $test_account = 'srv_and_tls'; my $conn_params = get_conn_params( $test_account ); my $auth_params = get_auth_params( $test_account ); my $my_full_jid = bare_jid( $test_account ) . '/' . $auth_params->{'resource'}; my $client = Net::XMPP::Client->new( debuglevel => 0, debug => 'stdout', ); isa_ok( $client, 'Net::XMPP::Client'); $client->SetCallBacks( onconnect => \&onConnect, onauth => \&onAuth, message => \&onMessage, ); $client->Execute( %{$auth_params}, %{$conn_params} ); sub onConnect { ok(1, 'Connected'); } # After successful authentication, send a test message to our full JID sub onAuth { ok( 1, 'Authenticated'); isa_ok( $client->PresenceSend(), 'Net::XMPP::Presence'); $client->MessageSend( to => $my_full_jid, subject => 'Test message', body => 'This is a test.' ); } # Check that the contents match what we sent above sub onMessage { my $sid = shift; my $message = shift; return unless $my_full_jid eq $message->GetFrom('jid')->GetJID('full'); is( $message->GetSubject(), 'Test message', 'Subject' ); is( $message->GetBody(), 'This is a test.', 'Body' ); $client->Disconnect(); exit(0); } } Net-XMPP-1.05/t/memory_cycle.t000444001750001750 133512446106423 17316 0ustar00dapatrickdapatrick000000000000use strict; use warnings; use Test::More; my $fail; BEGIN { eval "use Test::Memory::Cycle"; $fail = $@; } plan skip_all => 'Need Test::Memory::Cycle' if $fail; plan tests => 2; use Net::XMPP; my $conn = Net::XMPP::Client->new; memory_cycle_ok($conn, 'after creating object'); # TODO the user should be asked if he want to run networking tests! SKIP: { skip 'Needs AUTHORS_TEST', 1 if not $ENV{AUTHORS_TEST}; my $status = $conn->Connect( hostname => 'talk.google.com', port => 5222, componentname => 'gmail.com', connectiontype => 'tcpip', tls => 1, ssl_verify => 0, ); memory_cycle_ok($conn, 'after calling Connect'); } Net-XMPP-1.05/t/3_client_jabberd2.t000444001750001750 553612446106423 20071 0ustar00dapatrickdapatrick000000000000use 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 = Net::XMPP::Client->new(); $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); } Net-XMPP-1.05/t/node2.xml000444001750001750 66212446106423 16155 0ustar00dapatrickdapatrick000000000000RedRedshinyiconsNet-XMPP-1.05/t/query_xxxxx.test000444001750001750 204612446106423 17777 0ustar00dapatrickdapatrick000000000000use 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()" ); Net-XMPP-1.05/t/rawxml.t000444001750001750 405712446106423 16145 0ustar00dapatrickdapatrick000000000000use lib "t/lib"; use Test::More tests=>54; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $message = Net::XMPP::Message->new(); 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 = Net::XMPP::IQ->new(); 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()"); Net-XMPP-1.05/t/1_load.t000444001750001750 11412446106423 15740 0ustar00dapatrickdapatrick000000000000use lib "t/lib"; use Test::More tests=>1; BEGIN{ use_ok( "Net::XMPP" ); } Net-XMPP-1.05/t/memory_leak.t000444001750001750 226112446106423 17132 0ustar00dapatrickdapatrick000000000000use strict; use warnings; use Test::More; my $fail; BEGIN { eval "use Devel::LeakGuard::Object qw(leakguard)"; $fail = $@; } plan skip_all => 'Need Devel::LeakGuard::Object' if $fail; plan tests => 3; use Net::XMPP; check_leak( sub { my $x = bless {}, 'abc'; }, 'nothing', ); TODO: { local $TODO = 'fix leak'; check_leak( sub { my $conn = Net::XMPP::Client->new; $conn = undef; }, 'new', ); check_leak( sub { my $conn = Net::XMPP::Client->new; my $status = $conn->Connect( hostname => 'talk.google.com', port => 5222, componentname => 'gmail.com', connectiontype => 'tcpip', tls => 1, ssl_verify => 0, ); }, 'connect', ); } sub check_leak{ my ($sub) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; for my $c (1..10) { $sub->(); } my $warn; local $SIG{__WARN__} = sub { $warn = shift }; leakguard { for my $c (1..10) { $sub->(); #diag "Called $c"; } }; ok(!$warn, 'leaking') or diag $warn; } Net-XMPP-1.05/t/get_time_stamp.test000444001750001750 1210612446106423 20362 0ustar00dapatrickdapatrick000000000000# 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"); }Net-XMPP-1.05/t/roster.t000444001750001750 1522312446106423 16166 0ustar00dapatrickdapatrick000000000000use lib "t/lib"; use Test::More tests=>75; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = Net::XMPP::Debug->new(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); #------------------------------------------------------------------------------ # Client #------------------------------------------------------------------------------ my $Client = Net::XMPP::Client->new(); ok( defined($Client), "new()"); isa_ok($Client,"Net::XMPP::Client"); isa_ok($Client,"Net::XMPP::Connection"); #------------------------------------------------------------------------------ # Roster #------------------------------------------------------------------------------ my $Roster = Net::XMPP::Roster->new(connection=>$Client); ok( defined($Roster), "new()"); isa_ok($Roster,"Net::XMPP::Roster"); my $jid1 = '1test1@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"); Net-XMPP-1.05/t/node1.xml000444001750001750 64012446106423 16150 0ustar00dapatrickdapatrick000000000000bodybodyshinyicons Net-XMPP-1.05/t/jid.t000444001750001750 171312446106423 15375 0ustar00dapatrickdapatrick000000000000use lib "t/lib"; use Test::More tests=>15; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $jid = Net::XMPP::JID->new('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 = Net::XMPP::JID->new('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\")" ); Net-XMPP-1.05/t/presence.t000444001750001750 1467712446106423 16470 0ustar00dapatrickdapatrick000000000000use lib "t/lib"; use Test::More tests=>132; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = Net::XMPP::Debug->new(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); #------------------------------------------------------------------------------ # presence #------------------------------------------------------------------------------ my $presence = Net::XMPP::Presence->new(); 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 = Net::XMPP::Presence->new(); 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"); Net-XMPP-1.05/t/packet_iqroster.t000444001750001750 626412446106423 20034 0ustar00dapatrickdapatrick000000000000use lib "t/lib"; use Test::More tests=>57; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = Net::XMPP::Debug->new(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); my $query = Net::XMPP::Stanza->new("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()" ); Net-XMPP-1.05/t/packet_iqauth.t000444001750001750 431712446106423 17454 0ustar00dapatrickdapatrick000000000000use lib "t/lib"; use Test::More tests=>55; BEGIN{ use_ok( "Net::XMPP" ); } require "t/mytestlib.pl"; my $debug = Net::XMPP::Debug->new(setdefault=>1, level=>-1, file=>"stdout", header=>"test", ); my $query = Net::XMPP::Stanza->new("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 = Net::XMPP::Stanza->new("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()" ); Net-XMPP-1.05/t/config000755001750001750 012446106423 15550 5ustar00dapatrickdapatrick000000000000Net-XMPP-1.05/t/config/accounts.yml.copyme000444001750001750 43112446106423 21520 0ustar00dapatrickdapatrick000000000000# An account on a server supporting # TLS and having an SRV record in DNS srv_and_tls: bare_jid: you@example.com auth: password: som3passw0rd username: you conn: hostname: example.com port: 5222 srv: 1 ssl_ca_path: /path/to/ca/certificates tls: 1 Net-XMPP-1.05/t/lib000755001750001750 012446106423 15051 5ustar00dapatrickdapatrick000000000000Net-XMPP-1.05/t/lib/Net000755001750001750 012446106423 15577 5ustar00dapatrickdapatrick000000000000Net-XMPP-1.05/t/lib/Net/XMPP000755001750001750 012446106423 16363 5ustar00dapatrickdapatrick000000000000Net-XMPP-1.05/t/lib/Net/XMPP/Test000755001750001750 012446106423 17302 5ustar00dapatrickdapatrick000000000000Net-XMPP-1.05/t/lib/Net/XMPP/Test/Utils.pm000444001750001750 217612446106423 21103 0ustar00dapatrickdapatrick000000000000package Net::XMPP::Test::Utils; use strict; use warnings; use YAML::Tiny; use LWP::Online qw/online/; use Exporter 'import'; our @EXPORT_OK = (qw/ can_run_tests conn_is_available accts_are_configured bare_jid get_conn_params get_auth_params /); $Net::XMPP::Test::Utils::accounts_file = 't/config/accounts.yml'; sub can_run_tests { return conn_is_available() && accts_are_configured(); } sub conn_is_available { return online(); } sub accts_are_configured { return 1 if -e $Net::XMPP::Test::Utils::accounts_file && -r _ && -s _; return 0; } sub get_account { my ($wanted_account) = @_; $Net::XMPP::Test::Utils::accounts = YAML::Tiny->read( $Net::XMPP::Test::Utils::accounts_file ) unless defined $Net::XMPP::Test::Utils::accounts; return $Net::XMPP::Test::Utils::accounts->[0]->{$wanted_account}; } sub bare_jid { return get_account( shift )->{'bare_jid'}; } sub get_conn_params { return get_account( shift )->{'conn'}; } sub get_auth_params { my $resource = time . int(rand(1000)); chomp($resource); my $account = get_account( shift )->{'auth'}; $account->{'resource'} = $resource; return $account; } 1; Net-XMPP-1.05/lib000755001750001750 012446106423 14606 5ustar00dapatrickdapatrick000000000000Net-XMPP-1.05/lib/Net000755001750001750 012446106423 15334 5ustar00dapatrickdapatrick000000000000Net-XMPP-1.05/lib/Net/XMPP.pm000444001750001750 2722012446106423 16636 0ustar00dapatrickdapatrick000000000000############################################################################### # # 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: L =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 L 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 = Net::XMPP::Client->new(); =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 equivalent 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 =over 4 =item GetXML Returns the XML string that represents the data contained in the object. $xml = $obj->GetXML(); =item GetChild Returns an array of L objects 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"); =item GetTag Return the root tag name of the packet. =item GetTree Return the L object that contains the data. See XML::Stream::Node for methods you can call on this object. =back =head2 Creation functions =over 4 =item NewChild NewChild(namespace) NewChild(namespace,tag) Creates a new Net::XMPP::Stanza object with 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. =item InsertRawXML 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"); =item ClearRawXML ClearRawXML() Removes the raw XML from the packet. =back =head2 Removal functions =over 4 =item RemoveChild RemoveChild() RemoveChild(namespace) Removes all of the namespaces child elements from the object. If a namespace is provided, then only the children with that namespace are removed. =back =head2 Test functions =over 4 =item DefinedChild DefinedChild() DefinedChild(namespace) Returns 1 if there are any known namespaced 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"); =back =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 Originally authored by Ryan Eatmon. Previously maintained by Eric Hacker. Currently maintained by Darian Anthony Patrick. =head1 BUGS See unpatched issues at L. There is at least one issue with L 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 2.1. =cut require 5.008; use strict; use warnings; use Time::Local; use POSIX; use vars qw( $AUTOLOAD $VERSION $PARSING ); $VERSION = "1.05"; use XML::Stream; 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; Net-XMPP-1.05/lib/Net/XMPP000755001750001750 012446106423 16120 5ustar00dapatrickdapatrick000000000000Net-XMPP-1.05/lib/Net/XMPP/IQ.pm000444001750001750 2627412446106423 17157 0ustar00dapatrickdapatrick000000000000############################################################################## # # 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 = Net::XMPP::IQ->new(); $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 Originally authored by Ryan Eatmon. Previously maintained by Eric Hacker. Currently maintained by Darian Anthony Patrick. =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL 2.1. =cut require 5.008; use strict; use warnings; 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 Net::XMPP::IQ->new(); } $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; Net-XMPP-1.05/lib/Net/XMPP/Presence.pm000444001750001750 2305012446106423 20377 0ustar00dapatrickdapatrick000000000000############################################################################# # # 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 = Net::XMPP::Presence->new(); Now you can call the creation functions below to populate the tag before sending it. =head1 METHODS =head2 Retrieval functions =over 4 =item GetTo 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"); =item GetFrom 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"); =item GetType 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(); =item GetStatus GetStatus() returns a string with the current status of the resource. $status = $Pres->GetStatus(); =item GetPriority 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(); =item GetShow GetShow() Returns a string with the state the client should show. $show = $Pres->GetShow(); =back =head2 Creation functions =over 4 =item SetPresence SetPresence(to=>string|JID from=>string|JID, type=>string, status=>string, priority=>integer, meta=>string, icon=>string, show=>string, loc=>string) set multiple fields in the at one time. This is a cumulative and over writing action. If you set the "to" attribute twice, the second setting is what is used. If you set the status, and then set the priority then both will be in the tag. For valid settings read the specific Set functions below. $Pres->SetPresence(TYPE=>"away", StatuS=>"Out for lunch"); =item SetTo SetTo(string) SetTo(JID) sets the to attribute. You can either pass a string 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"); =item SetFrom 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"); =item SetType 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"); =item SetStatus SetStatus(string) sets the status tag to be whatever string the user wants associated with that resource. $Pres->SetStatus("Taking a nap"); =item SetPriority 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); =item SetShow SetShow(string) Sets the name of the icon or string to display for this resource. $Pres->SetShow("away"); =item Reply 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"); =back =head2 Removal functions =over 4 =item RemoveTo removes the to attribute from the . $Pres->RemoveTo(); =item RemoveFrom removes the from attribute from the . $Pres->RemoveFrom(); =item RemoveType removes the type attribute from the . $Pres->RemoveType(); =item RemoveStatus removes the element from the . $Pres->RemoveStatus(); =item RemovePriority removes the element from the . $Pres->RemovePriority(); =item RemoveShow removes the element from the . $Pres->RemoveShow(); =back =head2 Test functions =over 4 =item DefinedTo returns 1 if the to attribute is defined in the , 0 otherwise. $test = $Pres->DefinedTo(); =item DefinedFrom returns 1 if the from attribute is defined in the , 0 otherwise. $test = $Pres->DefinedFrom(); =item DefinedType returns 1 if the type attribute is defined in the , 0 otherwise. $test = $Pres->DefinedType(); =item DefinedStatus returns 1 if is defined in the , 0 otherwise. $test = $Pres->DefinedStatus(); =item DefinedPriority returns 1 if is defined in the , 0 otherwise. $test = $Pres->DefinedPriority(); =item DefinedShow returns 1 if is defined in the , 0 otherwise. $test = $Pres->DefinedShow(); =back =head1 AUTHOR Originally authored by Ryan Eatmon. Previously maintained by Eric Hacker. Currently maintained by Darian Anthony Patrick. =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL 2.1. =cut require 5.008; use strict; use warnings; 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 { return Net::XMPP::Presence->new(); } $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; Net-XMPP-1.05/lib/Net/XMPP/Connection.pm000444001750001750 3752212446106423 20743 0ustar00dapatrickdapatrick000000000000############################################################################## # # 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 Originally authored by Ryan Eatmon. Previously maintained by Eric Hacker. Currently maintained by Darian Anthony Patrick. =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL 2.1. =cut require 5.008; use strict; use warnings; use Carp; use Scalar::Util qw(weaken); use XML::Stream; use Net::XMPP::Debug; use Net::XMPP::Protocol; 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} = Net::XMPP::Debug->new(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} = XML::Stream->new(style => "node", debugfh => $self->{DEBUG}->GetHandle(), #debugfh => weaken $self->{DEBUG}->GetHandle(), debuglevel => $self->{DEBUG}->GetLevel(), debugtime => $self->{DEBUG}->GetTime(), ); $self->{RCVDB}->{currentID} = 0; $self->InitCallbacks(); # weaken $self->{STREAM}; weaken $self->{CB} if $self->{CB}; 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}, ( defined $self->{SERVER}->{ssl_ca_path} && '' ne $self->{SERVER}->{ssl_ca_path} ? (ssl_ca_path => $self->{SERVER}->{ssl_ca_path}) : () ), ( defined $self->{SERVER}->{ssl_verify} && '' ne $self->{SERVER}->{ssl_verify} ? (ssl_verify => $self->{SERVER}->{ssl_verify}) : () ), ssl => $self->{SERVER}->{ssl}, #LEGACY _tls => $self->{SERVER}->{tls}, ( defined $self->{SERVER}->{componentname} ? (to => $self->{SERVER}->{componentname}) : () ), ( defined $self->{SERVER}->{srv} ? (srv => '_xmpp-client._tcp') : () ), ); if ($self->{SESSION}) { $self->{DEBUG}->Log1("Connect: connection made"); my $weak = $self; weaken $weak; $self->{STREAM}->SetCallBacks(node=>sub{ $weak->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; Net-XMPP-1.05/lib/Net/XMPP/Message.pm000444001750001750 3213412446106423 20222 0ustar00dapatrickdapatrick000000000000############################################################################## # # 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 = Net::XMPP::Message->new(); 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 Originally authored by Ryan Eatmon. Previously maintained by Eric Hacker. Currently maintained by Darian Anthony Patrick. =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL 2.1. =cut require 5.008; use strict; use warnings; 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 Net::XMPP::Message->new(); } # 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; Net-XMPP-1.05/lib/Net/XMPP/JID.pm000444001750001750 2332412446106423 17245 0ustar00dapatrickdapatrick000000000000############################################################################## # # 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 = Net::XMPP::Foo->new(@_); my $from = $foo->GetFrom(); my $JID = Net::XMPP::JID->new($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 = Net::XMPP::JID->new(); 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 =over 4 =item GetUserID 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). =item GetServer GetServer() returns a string with the server of the JID. =item GerResource GetResource() returns a string with the resource of the JID. =item GetJID GetJID() GetJID("full") GetJID("base") returns a string that represents the JID stored within. If the "full" string is specified, then 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. =back =head2 Creation functions =over 4 =item SetJID SetJID(userid=>string, server=>string, resource=>string) SetJID(string) set multiple fields in the jid at one time. This is a cumulative and over writing action. If you set 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. =item SetUserID 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. =item SerServer SetServer(string) sets the server. Must be a valid host on the network or the server will not be able to talk to it. =item SetResource SetResource(string) sets the resource of the userid to talk to. =back =head1 AUTHOR Originally authored by Ryan Eatmon. Previously maintained by Eric Hacker. Currently maintained by Darian Anthony Patrick. =head1 COPYRIGHT This module is free software, you can redistribute it and/or modify it under the LGPL 2.1. =cut require 5.008; use strict; use warnings; 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; Net-XMPP-1.05/lib/Net/XMPP/Debug.pm000444001750001750 2444512446106423 17672 0ustar00dapatrickdapatrick000000000000############################################################################## # # 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 = Net::XMPP::Debug->new(); $Debug->Init( level => 2, file => "stdout", header =>"MyScript"); $Debug->Log0("Connection established"); =head1 METHODS =head2 Basic Functions =over 4 =item new new(hash) creates the Debug object. The hash argument is passed to the Init function. See that function description below for the valid settings. =item Init Init( level => integer, file => string, header => string, setdefault => 0|1, usedefault => 0|1, time => 0|1) initializes the debug object. The B determines the maximum level of debug messages to log: 0 - Base level Output (default) 1 - High level API calls 2 - Low level API calls ... N - Whatever you want.... The B 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. B
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"). B saves the current filehandle and makes it available for other Debug objects to use. To use the default set B to 1. The B