XML-Stream-1.23/0000755000175000017500000000000011321531274014015 5ustar dapatrickdapatrickXML-Stream-1.23/Makefile.PL0000644000175000017500000000166211317223470015775 0ustar dapatrickdapatrickuse 5.008_000; use ExtUtils::MakeMaker; WriteMakefile( (MM->can('signature_target') ? (SIGN => 1) : ()), 'NAME' => 'XML::Stream', 'VERSION_FROM' => 'lib/XML/Stream.pm', 'ABSTRACT_FROM' => 'lib/XML/Stream.pm', 'AUTHOR' => 'Darian Anthony Patrick ', 'LICENSE' => 'LGPL', 'MIN_PERL_VERSION' => '5.008', 'PREREQ_PM' => { 'Authen::SASL' => 0, 'MIME::Base64' => 0, 'Sys::Hostname' => 0, 'IO::Socket' => 0, 'IO::Select' => 0, 'FileHandle' => 0, 'Carp' => 0, 'POSIX' => 0, 'utf8' => 0, 'Encode' => 0, }, 'META_MERGE' => { 'resources' => { 'bugtracker' => 'https://rt.cpan.org/Dist/Display.html?Queue=XML-Stream', 'repository' => 'http://github.com/dap/XML-Stream', } }, ); XML-Stream-1.23/README0000644000175000017500000000142211317215444014677 0ustar dapatrickdapatrickXML::Stream v1.23_01 2009-12-31 This module provides you with access to XML Streams. An XML Stream is just that. A stream of XML over a connection between two computers. For more information about XML Streams, and the group that created them, please visit: http://xmpp.org/protocols/streams/ Darian Anthony Patrick dapatrick@cpan.org INSTALLATION perl Makefile.PL make make install REQUIREMENTS Perl 5.8.0 - For unicode support Authen::SASL - For SASL Authentication MIME::Base64 - For SASL Authentication RECOMMENDATIONS IO::Socket::SSL v0.81 - Module to enable TLS for XML::Stream. Net::DNS - Enables access to SRV records. Please submit bug reports at http://rt.cpan.org/Public/Bug/Report.html?Queue=XML-Stream XML-Stream-1.23/INFO0000644000175000017500000001706411316467730014514 0ustar dapatrickdapatrickXML::Stream Tree Building 101 In order to not reinvent the wheel, XML::Stream uses the XML::Parser::Tree object as the data structure it passes around and stores. Two things need to be covered in order to understand what the data looks like when you get it from XML::Stream. Section 1: What does an XML::Parser::Tree object look like? The original documentation for XML::Parser::Tree can be a little hard to understand so we will go over the structure here for completeness. The that is built is essentially a big nested array. This guarantees that you see the tags in the order receded from the stream, and that the nesting of tags is maintained. The actual structure of the tree is complicated so let's cover an example: SecondThird What we are working with is a nested tag inside the CDATA of . There are attributes on both tags that must be stored. To do this we use an array. The first element of the array is the root tag, or A. [ 'A' ] The second element is a list of all the things contained in . [ 'A', [ ] ] That new list is recursively built as you go down the hierarchy, so let's examine the structure. The first element of that new list is a hash of key/value pairs that represent the attributes of the tag you are looking at. In the case of the root tag the hash would be { 'n' => '1' }. So adding that to the list we get: [ 'A', [ { 'n' => '1' } ] ] Now, the rest of the new list is a set of two elements added at a time. Either a tag name followed by a list that represents the new tag, or a "0" (zero) followed by a string. This might be confusing so let's go to the example. As we parse the tag we see the string "First". So according to the rule we add a "0" and "First" to the list: [ 'A', [ { 'n' => '1' }, 0, "First" ] ] The next element is the tag. So the rules says that we add the tag and then a list that contains that tag: [ 'A', [ { 'n' => '1' }, 0, "First", 'B', [ ] ] ] Parsing the tag we see an attributes n = '2' and m = 'bob. So those go into a hash and that hash becomes the first element in the list for B: [ 'A', [ { 'n' => '1' }, 0, "First", 'B', [ { 'n' => '2', 'm' => 'bob' } ] ] ] Next we see that contains the CDATA "Second" so that goes into the list for B: [ 'A', [ { 'n' => '1' }, 0, "First", 'B', [ { 'n' => '2', 'm' => 'bob' } 0, "Second" ] ] ] closes and we leave this list and return to the list for . The next element there is CDATA so add a '0' and "Third" onto the list for A: [ 'A', [ { 'n' => '1' }, 0, "First", 'B', [ { 'n' => '2', 'm' => 'bob' } 0, "Second" ] 0, "Third" ] ] Now we see another tag, . So we add C and a list onto the A's list: [ 'A', [ { 'n' => '1' }, 0, "First", 'B', [ { 'n' => '2', 'm' => 'bob' } 0, "Second" ] 0, "Third", 'C', [ ] ] ] Parsing we see that it has no attributes so we add an empty hash to the list for C: [ 'A', [ { 'n' => '1' }, 0, "First", 'B', [ { 'n' => '2', 'm' => 'bob' } 0, "Second" ] 0, "Third", 'C', [ { } ] ] ] Next we see that contains no other data and ends in a />. This means that the tag is finished and contains no data. So close C and go back to . There is no other data in A so we close and we have our finished tree: [ 'A', [ { 'n' => '1' }, 0, "First", 'B', [ { 'n' => '2', 'm' => 'bob' } 0, "Second" ] 0, "Third", 'C', [ { } ] ] ] Section II: How do we build the XML::Parser::Tree? For those who are interested in how we build a tree read on, for those that got enough out of the previous section, read anyway. Recursion would be too difficult to do in this linear problem so we looked at the problem and engineered a way to use a single list to build the structure. Every time a new tag is encountered a new list is added to end of the main list. When that list closes it is removed from the main list and then added onto the end of the previous element in the list, which is usually another list. In other words: The current list looks like this: [aaa] We see a new tag and make a new list: [aaa], [bbb] Populate that list and then close it. When we close we remove from the list and make it the last element in the previous list elements list. Confused? Watch: [aaa], [bbb] --> [aaa, [bbb] ] As we "recurse" the hierarchy and close tags we push the new list back up to the previous list element and create the proper nesting. Let's go over the same example from Section I. SecondThird We start and push A on the list: [ 'A' ] Next we create a new list for the tag and populate the attribute hash: [ 'A', [ { 'n'=>'1' } ] ] Now we see the CDATA: [ 'A', [ { 'n'=>'1' }, 0, "First" ] ] Next it's the tag, so push B on the list and make a new list on the end of the main list: [ 'A', [ { 'n'=>'1' }, 0, "First", 'B' ], [ ] ] Parsing the tag we see that is has attributes and CDATA: [ 'A', [ { 'n'=>'1' }, 0, "First", 'B' ], [ {'n'=>'2','m'=>"bob"}, 0, "Second" ] ] Now closes and the magic begins... With the closing of we pop the last element off the list. Then we take that element and push it onto the last element of the main list. So we aren't pushing it onto the main list, but onto the last element of the main list: Popped value: [ {'n'=>'2','m'=>"bob"}, 0, "Second" ] List: [ 'A', [ { 'n'=>'1' }, 0, "First", 'B' ] ] Push value on last element of list: [ 'A', [ { 'n'=>'1' }, 0, "First", 'B', [ {'n'=>'2','m'=>"bob"}, 0, "Second" ] ] ] Now we see a CDATA and push that onto the last element in the list: [ 'A', [ { 'n'=>'1' }, 0, "First", 'B', [ {'n'=>'2','m'=>"bob"}, 0, "Second" ], 0, "Third" ] ] Finally we see the tag, so a 'C' is pushed onto the list, and then a new list is created to contain the new tag: [ 'A', [ { 'n'=>'1' }, 0, "First", 'B', [ {'n'=>'2','m'=>"bob"}, 0, "Second" ], 0, "Third", 'C' ], [ ] ] no attributes so an empty hash is pushed onto the list: [ 'A', [ { 'n'=>'1' }, 0, "First", 'B', [ {'n'=>'2','m'=>"bob"}, 0, "Second" ], 0, "Third", 'C' ], [ { } ] ] contains no data so nothing is to be done there. The tag closes and we do the magic again. Pop the last element off the main list and push it onto the previous element's list: [ 'A', [ { 'n'=>'1' }, 0, "First", 'B', [ {'n'=>'2','m'=>"bob"}, 0, "Second" ], 0, "Third", 'C', [ { } ] ] ] Now closes so we pop the last element off the main list and push is onto a list with the previous element, which is the string 'A': [ 'A', [ { 'n'=>'1' }, 0, "First", 'B', [ {'n'=>'2','m'=>"bob"}, 0, "Second" ], 0, "Third", 'C', [ { } ] ] ] And voila! The tree is complete. We now call the callback function, pass it the tree, and then reset the tree for the next tag to be parsed. XML-Stream-1.23/SIGNATURE0000644000175000017500000000537611321531274015314 0ustar dapatrickdapatrickThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.61. 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 15d61963df469cda6d0e12f471866856dd4b6952 CHANGES SHA1 196d154af87fc5e3d911add822f01102f2b924da INFO SHA1 8ff23a37b0bf322b7e4e73d5ceeec7f417f5eaa9 LICENSE.LGPL SHA1 cd0584c8c15178944fbd3f0bece34b837782c49d MANIFEST SHA1 32e1b15c490b7d6d778a8c85ef599b05840c25ac META.yml SHA1 8928801747c656d078c7f69ff3ec88a19d714ac9 Makefile.PL SHA1 5147913455418c51a15ed05a87431f2ebac8afbf README SHA1 de809bcc59a173081dd185faf1f949acb02c9b32 lib/XML/Stream.pm SHA1 65d7eb5df10bf9bff56da827edf701133dc34239 lib/XML/Stream/IO/Select/Win32.pm SHA1 1881347c3a7bc6b27bbc6ff639ba56be835939d4 lib/XML/Stream/Namespace.pm SHA1 9dd6cca9d062173cb8115e7ed1a30cb4fb8bb417 lib/XML/Stream/Node.pm SHA1 ca408e2e322974ce7e40ceb113c02ec24894fbd2 lib/XML/Stream/Parser.pm SHA1 b4d59b4741269a9ff6ceb0fe62235c27556a8a8d lib/XML/Stream/Parser/DTD.pm SHA1 e4259c7b57d3ce93364d4189def440e3c395606c lib/XML/Stream/Tree.pm SHA1 ff63c6ad822b958754d8e7ae7b8da4a2cd732aac lib/XML/Stream/XPath.pm SHA1 27614a513004374070fcb808d981214a84a794b8 lib/XML/Stream/XPath/Op.pm SHA1 ff730f0ccbb026aef431a33f3b83e3526a16811e lib/XML/Stream/XPath/Query.pm SHA1 99f41e999e62a92f95527bc863aef978f2140a5a lib/XML/Stream/XPath/Value.pm SHA1 4aeb184c9bed26ab6c3be1ebdb8470c0cb353b1f t/0-signature.t SHA1 df699ebee5bf1cb549949164b410865cbd4c2e0d t/buildxml.t SHA1 e2c38563da2f61b28f051c882942158eff4fe1b1 t/cdata.t SHA1 1febe2e170ead4f8f5865f31fd72746c03dd3cce t/lib/Test/Builder.pm SHA1 51c49a3df7cc24f3507c97c16f11c0f87e6f51e7 t/lib/Test/More.pm SHA1 871dd89f9b3404ee836da317db33c61295035f7c t/lib/Test/Simple.pm SHA1 ff41418f62760f89718aa1b11ac953cd8bb40f2e t/load.t SHA1 ab53c6def56ac1b9937ef78c9a2c35c9803ce339 t/parse_node.t SHA1 add9d3c6d91dc1ca9d66a5c514c604759c88286e t/parse_tree.t SHA1 317215868bfd167d3c21ae8e4376d9e03093008f t/quotes.t SHA1 7766dfdd99dbaed56e4dcd21150880a2fb3de3dc t/tcpip.t SHA1 1091b6ccd6a0d30eab17fe90306f709aae5c1464 t/tcpip2ssl.t SHA1 191c3a9c3eeca7b58b096436ee241342e6984d2f t/test.xml SHA1 d42030a31535a17e4e8b10a824d8843ec30f8e57 t/xml2config.t SHA1 ed9e965ddcc3ad37c8243595b793c112c4476e01 t/xpath.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.9 (GNU/Linux) iEYEARECAAYFAktGsrwACgkQjJ7fFJrTQRdsWgCeP/s2EkHm5jy+TayY6IzVkfUF dlEAmwb6N1iLSTEcL+uZlD4LfOFOCYB4 =B3sH -----END PGP SIGNATURE----- XML-Stream-1.23/lib/0000755000175000017500000000000011321531273014562 5ustar dapatrickdapatrickXML-Stream-1.23/lib/XML/0000755000175000017500000000000011321531273015222 5ustar dapatrickdapatrickXML-Stream-1.23/lib/XML/Stream.pm0000644000175000017500000034562211321524555017034 0ustar dapatrickdapatrick############################################################################## # # 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. # # Jabber # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package XML::Stream; =head1 NAME XML::Stream - Creates an XML Stream connection and parses return data =head1 SYNOPSIS XML::Stream is an attempt at solidifying the use of XML via streaming. =head1 DESCRIPTION This module provides the user with methods to connect to a remote server, send a stream of XML to the server, and receive/parse an XML stream from the server. It is primarily based work for the Etherx XML router developed by the Jabber Development Team. For more information about this project visit http://xmpp.org/protocols/streams/. XML::Stream gives the user the ability to define a central callback that will be used to handle the tags received from the server. These tags are passed in the format defined at instantiation time. the closing tag of an object is seen, the tree is finished and passed to the call back function. What the user does with it from there is up to them. For a detailed description of how this module works, and about the data structure that it returns, please view the source of Stream.pm and look at the detailed description at the end of the file. NOTE: The parser that XML::Stream::Parser provides, as are most Perl parsers, is synchronous. If you are in the middle of parsing a packet and call a user defined callback, the Parser is blocked until your callback finishes. This means you cannot be operating on a packet, send out another packet and wait for a response to that packet. It will never get to you. Threading might solve this, but as we all know threading in Perl is not quite up to par yet. This issue will be revisted in the future. =head1 METHODS new(debug=>string, - creates the XML::Stream object. debug debugfh=>FileHandle, should be set to the path for the debug log debuglevel=>0|1|N, to be written. If set to "stdout" then the debugtime=>0|1, debug will go there. Also, you can specify style=>string) a filehandle that already exists byt using debugfh. debuglevel determines the amount of debug to generate. 0 is the least, 1 is a little more, N is the limit you want. debugtime determines wether a timestamp should be preappended to the entry. style defines the way the data structure is returned. The two available styles are: tree - XML::Parser Tree format node - XML::Stream::Node format For more information see the respective man pages. Connect(hostname=>string, - opens a tcp connection to the port=>integer, specified server and sends the proper to=>string, opening XML Stream tag. hostname, from=>string, port, and namespace are required. myhostname=>string, namespaces allows you to use namespace=>string, XML::Stream::Namespace objects. namespaces=>array, to is needed if you want the stream connectiontype=>string, to attribute to be something other ssl=>0|1, than the hostname you are connecting srv=>string) to. from is needed if you want the stream from attribute to be something other than the hostname you are connecting from. myhostname should not be needed but if the module cannot determine your hostname properly (check the debug log), set this to the correct value, or if you want the other side of the stream to think that you are someone else. The type determines the kind of connection that is made: "tcpip" - TCP/IP (default) "stdinout" - STDIN/STDOUT "http" - HTTP HTTP recognizes proxies if the ENV variables http_proxy or https_proxy are set. ssl specifies if an SSL socket should be used for encrypted communications. This function returns the same hash from GetRoot() below. Make sure you get the SID (Session ID) since you have to use it to call most other functions in here. If srv is specified AND Net::DNS is installed and can be loaded, then an SRV query is sent to srv.hostname and the results processed to replace the hostname and port. If the lookup fails, or Net::DNS cannot be loaded, then hostname and port are left alone as the defaults. OpenFile(string) - opens a filehandle to the argument specified, and pretends that it is a stream. It will ignore the outer tag, and not check if it was a . This is useful for writing a program that has to parse any XML file that is basically made up of small packets (like RDF). Disconnect(sid) - sends the proper closing XML tag and closes the specified socket down. Process(integer) - waits for data to be available on the socket. If a timeout is specified then the Process function waits that period of time before returning nothing. If a timeout period is not specified then the function blocks until data is received. The function returns a hash with session ids as the key, and status values or data as the hash values. SetCallBacks(node=>function, - sets the callback that should be update=>function) called in various situations. node is used to handle the data structures that are built for each top level tag. Update is used for when Process is blocking waiting for data, but you want your original code to be updated. GetRoot(sid) - returns the attributes that the stream:stream tag sent by the other end listed in a hash for the specified session. GetSock(sid) - returns a pointer to the IO::Socket object for the specified session. Send(sid, - sends the string over the specified connection as is. string) This does no checking if valid XML was sent or not. Best behavior when sending information. GetErrorCode(sid) - returns a string for the specified session that will hopefully contain some useful information about why Process or Connect returned an undef to you. XPath(node,path) - returns an array of results that match the xpath. node can be any of the three types (Tree, Node). =head1 VARIABLES $NONBLOCKING - tells the Parser to enter into a nonblocking state. This might cause some funky behavior since you can get nested callbacks while things are waiting. 1=on, 0=off(default). =head1 EXAMPLES ########################## # simple example use XML::Stream qw( Tree ); $stream = new XML::Stream; my $status = $stream->Connect(hostname => "jabber.org", port => 5222, namespace => "jabber:client"); if (!defined($status)) { print "ERROR: Could not connect to server\n"; print " (",$stream->GetErrorCode(),")\n"; exit(0); } while($node = $stream->Process()) { # do something with $node } $stream->Disconnect(); ########################### # example using a handler use XML::Stream qw( Tree ); $stream = new XML::Stream; $stream->SetCallBacks(node=>\&noder); $stream->Connect(hostname => "jabber.org", port => 5222, namespace => "jabber:client", timeout => undef) || die $!; # Blocks here forever, noder is called for incoming # packets when they arrive. while(defined($stream->Process())) { } print "ERROR: Stream died (",$stream->GetErrorCode(),")\n"; sub noder { my $sid = shift; my $node = shift; # do something with $node } =head1 AUTHOR Tweaked, tuned, and brightness changes by Ryan Eatmon, reatmon@ti.com in May of 2000. Colorized, and Dolby Surround sound added by Thomas Charron, tcharron@jabber.org By Jeremie in October of 1999 for http://etherx.jabber.org/streams/ Currently maintained by Darian Anthony Patrick. =head1 COPYRIGHT This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use 5.008; use strict; use Sys::Hostname; use IO::Socket; use IO::Select; use FileHandle; use Carp; use POSIX; use Authen::SASL; use MIME::Base64; use utf8; use Encode; use XML::Stream::IO::Select::Win32; $SIG{PIPE} = "IGNORE"; use vars qw($VERSION $PAC $SSL $NONBLOCKING %HANDLERS $NETDNS %XMLNS ); ############################################################################## # Define the namespaces in an easy/constant manner. #----------------------------------------------------------------------------- # 0.9 #----------------------------------------------------------------------------- $XMLNS{'stream'} = "http://etherx.jabber.org/streams"; #----------------------------------------------------------------------------- # 1.0 #----------------------------------------------------------------------------- $XMLNS{'xmppstreams'} = "urn:ietf:params:xml:ns:xmpp-streams"; $XMLNS{'xmpp-bind'} = "urn:ietf:params:xml:ns:xmpp-bind"; $XMLNS{'xmpp-sasl'} = "urn:ietf:params:xml:ns:xmpp-sasl"; $XMLNS{'xmpp-session'} = "urn:ietf:params:xml:ns:xmpp-session"; $XMLNS{'xmpp-tls'} = "urn:ietf:params:xml:ns:xmpp-tls"; ############################################################################## if (eval "require Net::DNS;" ) { require Net::DNS; import Net::DNS; $NETDNS = 1; } else { $NETDNS = 0; } $VERSION = "1.23"; $NONBLOCKING = 0; use XML::Stream::Namespace; use XML::Stream::Parser; use XML::Stream::XPath; ############################################################################## # # Setup the exportable objects # ############################################################################## require Exporter; my @ISA = qw(Exporter); my @EXPORT_OK = qw(Tree Node); sub import { my $class = shift; foreach my $module (@_) { eval "use XML::Stream::$module;"; die($@) if ($@); my $lc = lc($module); eval("\$HANDLERS{\$lc}->{startElement} = \\&XML::Stream::${module}::_handle_element;"); eval("\$HANDLERS{\$lc}->{endElement} = \\&XML::Stream::${module}::_handle_close;"); eval("\$HANDLERS{\$lc}->{characters} = \\&XML::Stream::${module}::_handle_cdata;"); } } sub new { my $proto = shift; my $self = { }; bless($self,$proto); my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $self->{DATASTYLE} = "tree"; $self->{DATASTYLE} = delete($args{style}) if exists($args{style}); if ((($self->{DATASTYLE} eq "tree") && !defined($XML::Stream::Tree::LOADED)) || (($self->{DATASTYLE} eq "node") && !defined($XML::Stream::Node::LOADED)) ) { croak("The style that you have chosen was not defined when you \"use\"d the module.\n"); } $self->{DEBUGARGS} = \%args; $self->{DEBUGTIME} = 0; $self->{DEBUGTIME} = $args{debugtime} if exists($args{debugtime}); $self->{DEBUGLEVEL} = 0; $self->{DEBUGLEVEL} = $args{debuglevel} if exists($args{debuglevel}); $self->{DEBUGFILE} = ""; if (exists($args{debugfh}) && ($args{debugfh} ne "")) { $self->{DEBUGFILE} = $args{debugfh}; $self->{DEBUG} = 1; } if ((exists($args{debugfh}) && ($args{debugfh} eq "")) || (exists($args{debug}) && ($args{debug} ne ""))) { $self->{DEBUG} = 1; if (lc($args{debug}) eq "stdout") { $self->{DEBUGFILE} = new FileHandle(">&STDERR"); $self->{DEBUGFILE}->autoflush(1); } else { if (-e $args{debug}) { if (-w $args{debug}) { $self->{DEBUGFILE} = new FileHandle(">$args{debug}"); $self->{DEBUGFILE}->autoflush(1); } else { print "WARNING: debug file ($args{debug}) is not writable by you\n"; print " No debug information being saved.\n"; $self->{DEBUG} = 0; } } else { $self->{DEBUGFILE} = new FileHandle(">$args{debug}"); if (defined($self->{DEBUGFILE})) { $self->{DEBUGFILE}->autoflush(1); } else { print "WARNING: debug file ($args{debug}) does not exist \n"; print " and is not writable by you.\n"; print " No debug information being saved.\n"; $self->{DEBUG} = 0; } } } } my $hostname = hostname(); my $address = gethostbyname($hostname) || die("Cannot resolve $hostname: $!"); my $fullname = gethostbyaddr($address,AF_INET) || $hostname; $self->debug(1,"new: hostname = ($fullname)"); #--------------------------------------------------------------------------- # Setup the defaults that the module will work with. #--------------------------------------------------------------------------- $self->{SIDS}->{default}->{hostname} = ""; $self->{SIDS}->{default}->{port} = ""; $self->{SIDS}->{default}->{sock} = 0; $self->{SIDS}->{default}->{ssl} = (exists($args{ssl}) ? $args{ssl} : 0); $self->{SIDS}->{default}->{namespace} = ""; $self->{SIDS}->{default}->{myhostname} = $fullname; $self->{SIDS}->{default}->{derivedhostname} = $fullname; $self->{SIDS}->{default}->{id} = ""; #--------------------------------------------------------------------------- # We are only going to use one callback, let the user call other callbacks # on his own. #--------------------------------------------------------------------------- $self->SetCallBacks(node=>sub { $self->_node(@_) }); $self->{IDCOUNT} = 0; return $self; } ############################################################################## #+---------------------------------------------------------------------------- #| #| Incoming Connection Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # Listen - starts the stream by listening on a port for someone to connect, # and send the opening stream tag, and then sending a response based # on if the received header was correct for this stream. Server # name, port, and namespace are required otherwise we don't know # where to listen and what namespace to accept. # ############################################################################## sub Listen { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $serverid = "server$args{port}"; return if exists($self->{SIDS}->{$serverid}); push(@{$self->{SIDS}->{server}},$serverid); foreach my $key (keys(%{$self->{SIDS}->{default}})) { $self->{SIDS}->{$serverid}->{$key} = $self->{SIDS}->{default}->{$key}; } foreach my $key (keys(%args)) { $self->{SIDS}->{$serverid}->{$key} = $args{$key}; } $self->debug(1,"Listen: start"); if ($self->{SIDS}->{$serverid}->{namespace} eq "") { $self->SetErrorCode($serverid,"Namespace not specified"); return; } #--------------------------------------------------------------------------- # Check some things that we have to know in order get the connection up # and running. Server hostname, port number, namespace, etc... #--------------------------------------------------------------------------- if ($self->{SIDS}->{$serverid}->{hostname} eq "") { $self->SetErrorCode("$serverid","Server hostname not specified"); return; } if ($self->{SIDS}->{$serverid}->{port} eq "") { $self->SetErrorCode("$serverid","Server port not specified"); return; } if ($self->{SIDS}->{$serverid}->{myhostname} eq "") { $self->{SIDS}->{$serverid}->{myhostname} = $self->{SIDS}->{$serverid}->{derivedhostname}; } #------------------------------------------------------------------------- # Open the connection to the listed server and port. If that fails then # abort ourselves and let the user check $! on his own. #------------------------------------------------------------------------- while($self->{SIDS}->{$serverid}->{sock} == 0) { $self->{SIDS}->{$serverid}->{sock} = new IO::Socket::INET(LocalHost=>$self->{SIDS}->{$serverid}->{hostname}, LocalPort=>$self->{SIDS}->{$serverid}->{port}, Reuse=>1, Listen=>10, Proto=>'tcp'); select(undef,undef,undef,.1); } $self->{SIDS}->{$serverid}->{status} = 1; $self->nonblock($self->{SIDS}->{$serverid}->{sock}); $self->{SIDS}->{$serverid}->{sock}->autoflush(1); $self->{SELECT} = new IO::Select($self->{SIDS}->{$serverid}->{sock}); $self->{SIDS}->{$serverid}->{select} = new IO::Select($self->{SIDS}->{$serverid}->{sock}); $self->{SOCKETS}->{$self->{SIDS}->{$serverid}->{sock}} = "$serverid"; return $serverid; } ############################################################################## # # ConnectionAccept - accept an incoming connection. # ############################################################################## sub ConnectionAccept { my $self = shift; my $serverid = shift; my $sid = $self->NewSID(); $self->debug(1,"ConnectionAccept: sid($sid)"); $self->{SIDS}->{$sid}->{sock} = $self->{SIDS}->{$serverid}->{sock}->accept(); $self->nonblock($self->{SIDS}->{$sid}->{sock}); $self->{SIDS}->{$sid}->{sock}->autoflush(1); $self->debug(3,"ConnectionAccept: sid($sid) client($self->{SIDS}->{$sid}->{sock}) server($self->{SIDS}->{$serverid}->{sock})"); $self->{SELECT}->add($self->{SIDS}->{$sid}->{sock}); #------------------------------------------------------------------------- # Create the XML::Stream::Parser and register our callbacks #------------------------------------------------------------------------- $self->{SIDS}->{$sid}->{parser} = new XML::Stream::Parser(%{$self->{DEBUGARGS}}, nonblocking=>$NONBLOCKING, sid=>$sid, style=>$self->{DATASTYLE}, Handlers=>{ startElement=>sub{ $self->_handle_root(@_) }, endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) }, characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) }, } ); $self->{SIDS}->{$sid}->{select} = new IO::Select($self->{SIDS}->{$sid}->{sock}); $self->{SIDS}->{$sid}->{connectiontype} = "tcpip"; $self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}} = $sid; $self->InitConnection($sid,$serverid); #--------------------------------------------------------------------------- # Grab the init time so that we can check if we get data in the timeout # period or not. #--------------------------------------------------------------------------- $self->{SIDS}->{$sid}->{activitytimeout} = time; return $sid; } ############################################################################## # # Respond - If this is a listening socket then we need to respond to the # opening . # ############################################################################## sub Respond { my $self = shift; my $sid = shift; my $serverid = $self->{SIDS}->{$sid}->{serverid}; my $root = $self->GetRoot($sid); if ($root->{xmlns} ne $self->{SIDS}->{$serverid}->{namespace}) { my $error = $self->StreamError($sid,"invalid-namespace","Invalid namespace specified"); $self->Send($sid,$error); $self->{SIDS}->{$sid}->{sock}->flush(); select(undef,undef,undef,1); $self->Disconnect($sid); } #--------------------------------------------------------------------------- # Next, we build the opening handshake. #--------------------------------------------------------------------------- my %stream_args; $stream_args{from} = (exists($self->{SIDS}->{$serverid}->{from}) ? $self->{SIDS}->{$serverid}->{from} : $self->{SIDS}->{$serverid}->{hostname} ); $stream_args{to} = $self->GetRoot($sid)->{from}; $stream_args{id} = $sid; $stream_args{namespaces} = $self->{SIDS}->{$serverid}->{namespaces}; my $stream = $self->StreamHeader( xmlns=>$self->{SIDS}->{$serverid}->{namespace}, xmllang=>"en", %stream_args ); #--------------------------------------------------------------------------- # Then we send the opening handshake. #--------------------------------------------------------------------------- $self->Send($sid,$stream); delete($self->{SIDS}->{$sid}->{activitytimeout}); } ############################################################################## #+---------------------------------------------------------------------------- #| #| Outgoing Connection Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # Connect - starts the stream by connecting to the server, sending the opening # stream tag, and then waiting for a response and verifying that it # is correct for this stream. Server name, port, and namespace are # required otherwise we don't know where to send the stream to... # ############################################################################## sub Connect { my $self = shift; foreach my $key (keys(%{$self->{SIDS}->{default}})) { $self->{SIDS}->{newconnection}->{$key} = $self->{SIDS}->{default}->{$key}; } while($#_ >= 0) { $self->{SIDS}->{newconnection}->{ lc pop(@_) } = pop(@_); } my $timeout = exists($self->{SIDS}->{newconnection}->{timeout}) ? delete($self->{SIDS}->{newconnection}->{timeout}) : ""; $self->debug(4,"Connect: timeout($timeout)"); if (exists($self->{SIDS}->{newconnection}->{srv})) { $self->debug(1,"Connect: srv requested"); if ($NETDNS) { my $res = Net::DNS::Resolver->new(); my $query = $res->query($self->{SIDS}->{newconnection}->{srv}.".".$self->{SIDS}->{newconnection}->{hostname},"SRV"); if ($query) { $self->{SIDS}->{newconnection}->{hostname} = ($query->answer)[0]->target(); $self->{SIDS}->{newconnection}->{port} = ($query->answer)[0]->port(); $self->debug(1,"Connect: srv host: $self->{SIDS}->{newconnection}->{hostname}"); $self->debug(1,"Connect: srv post: $self->{SIDS}->{newconnection}->{port}"); } else { $self->debug(1,"Connect: srv query failed"); } } else { $self->debug(1,"Connect: srv query failed"); } delete($self->{SIDS}->{newconnection}->{srv}); } $self->{SIDS}->{newconnection}->{connectiontype} = "tcpip" unless exists($self->{SIDS}->{newconnection}->{connectiontype}); $self->debug(1,"Connect: type($self->{SIDS}->{newconnection}->{connectiontype})"); if ($self->{SIDS}->{newconnection}->{namespace} eq "") { $self->SetErrorCode("newconnection","Namespace not specified"); return; } #--------------------------------------------------------------------------- # TCP/IP #--------------------------------------------------------------------------- if ($self->{SIDS}->{newconnection}->{connectiontype} eq "tcpip") { #----------------------------------------------------------------------- # Check some things that we have to know in order get the connection up # and running. Server hostname, port number, namespace, etc... #----------------------------------------------------------------------- if ($self->{SIDS}->{newconnection}->{hostname} eq "") { $self->SetErrorCode("newconnection","Server hostname not specified"); return; } if ($self->{SIDS}->{newconnection}->{port} eq "") { $self->SetErrorCode("newconnection","Server port not specified"); return; } if ($self->{SIDS}->{newconnection}->{myhostname} eq "") { $self->{SIDS}->{newconnection}->{myhostname} = $self->{SIDS}->{newconnection}->{derivedhostname}; } #----------------------------------------------------------------------- # Open the connection to the listed server and port. If that fails then # abort ourselves and let the user check $! on his own. #----------------------------------------------------------------------- $self->{SIDS}->{newconnection}->{sock} = new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{hostname}, PeerPort=>$self->{SIDS}->{newconnection}->{port}, Proto=>"tcp", (($timeout ne "") ? ( Timeout=>$timeout ) : ()), ); return unless $self->{SIDS}->{newconnection}->{sock}; if ($self->{SIDS}->{newconnection}->{ssl} == 1) { $self->debug(1,"Connect: Convert normal socket to SSL"); $self->debug(1,"Connect: sock($self->{SIDS}->{newconnection}->{sock})"); $self->LoadSSL(); $self->{SIDS}->{newconnection}->{sock} = IO::Socket::SSL::socketToSSL($self->{SIDS}->{newconnection}->{sock}, {SSL_verify_mode=>0x00}); $self->debug(1,"Connect: ssl_sock($self->{SIDS}->{newconnection}->{sock})"); $self->debug(1,"Connect: SSL: We are secure") if ($self->{SIDS}->{newconnection}->{sock}); } return unless $self->{SIDS}->{newconnection}->{sock}; } #--------------------------------------------------------------------------- # STDIN/OUT #--------------------------------------------------------------------------- if ($self->{SIDS}->{newconnection}->{connectiontype} eq "stdinout") { $self->{SIDS}->{newconnection}->{sock} = new FileHandle(">&STDOUT"); } #--------------------------------------------------------------------------- # HTTP #--------------------------------------------------------------------------- if ($self->{SIDS}->{newconnection}->{connectiontype} eq "http") { #----------------------------------------------------------------------- # Check some things that we have to know in order get the connection up # and running. Server hostname, port number, namespace, etc... #----------------------------------------------------------------------- if ($self->{SIDS}->{newconnection}->{hostname} eq "") { $self->SetErrorCode("newconnection","Server hostname not specified"); return; } if ($self->{SIDS}->{newconnection}->{port} eq "") { $self->SetErrorCode("newconnection","Server port not specified"); return; } if ($self->{SIDS}->{newconnection}->{myhostname} eq "") { $self->{SIDS}->{newconnection}->{myhostname} = $self->{SIDS}->{newconnection}->{derivedhostname}; } if (!defined($PAC)) { eval("use HTTP::ProxyAutoConfig;"); if ($@) { $PAC = 0; } else { require HTTP::ProxyAutoConfig; $PAC = new HTTP::ProxyAutoConfig(); } } if ($PAC eq "0") { if (exists($ENV{"http_proxy"})) { my($host,$port) = ($ENV{"http_proxy"} =~ /^(\S+)\:(\d+)$/); $self->{SIDS}->{newconnection}->{httpproxyhostname} = $host; $self->{SIDS}->{newconnection}->{httpproxyport} = $port; $self->{SIDS}->{newconnection}->{httpproxyhostname} =~ s/^http\:\/\///; } if (exists($ENV{"https_proxy"})) { my($host,$port) = ($ENV{"https_proxy"} =~ /^(\S+)\:(\d+)$/); $self->{SIDS}->{newconnection}->{httpsproxyhostname} = $host; $self->{SIDS}->{newconnection}->{httpsproxyport} = $port; $self->{SIDS}->{newconnection}->{httpsproxyhostname} =~ s/^https?\:\/\///; } } else { my $proxy = $PAC->FindProxy("http://".$self->{SIDS}->{newconnection}->{hostname}); if ($proxy ne "DIRECT") { ($self->{SIDS}->{newconnection}->{httpproxyhostname},$self->{SIDS}->{newconnection}->{httpproxyport}) = ($proxy =~ /^PROXY ([^:]+):(\d+)$/); } $proxy = $PAC->FindProxy("https://".$self->{SIDS}->{newconnection}->{hostname}); if ($proxy ne "DIRECT") { ($self->{SIDS}->{newconnection}->{httpsproxyhostname},$self->{SIDS}->{newconnection}->{httpsproxyport}) = ($proxy =~ /^PROXY ([^:]+):(\d+)$/); } } $self->debug(1,"Connect: http_proxy($self->{SIDS}->{newconnection}->{httpproxyhostname}:$self->{SIDS}->{newconnection}->{httpproxyport})") if (exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) && defined($self->{SIDS}->{newconnection}->{httpproxyhostname}) && exists($self->{SIDS}->{newconnection}->{httpproxyport}) && defined($self->{SIDS}->{newconnection}->{httpproxyport})); $self->debug(1,"Connect: https_proxy($self->{SIDS}->{newconnection}->{httpsproxyhostname}:$self->{SIDS}->{newconnection}->{httpsproxyport})") if (exists($self->{SIDS}->{newconnection}->{httpsproxyhostname}) && defined($self->{SIDS}->{newconnection}->{httpsproxyhostname}) && exists($self->{SIDS}->{newconnection}->{httpsproxyport}) && defined($self->{SIDS}->{newconnection}->{httpsproxyport})); #----------------------------------------------------------------------- # Open the connection to the listed server and port. If that fails then # abort ourselves and let the user check $! on his own. #----------------------------------------------------------------------- my $connect = "CONNECT $self->{SIDS}->{newconnection}->{hostname}:$self->{SIDS}->{newconnection}->{port} HTTP/1.1\r\nHost: $self->{SIDS}->{newconnection}->{hostname}\r\n\r\n"; my $put = "PUT http://$self->{SIDS}->{newconnection}->{hostname}:$self->{SIDS}->{newconnection}->{port} HTTP/1.1\r\nHost: $self->{SIDS}->{newconnection}->{hostname}\r\nProxy-Connection: Keep-Alive\r\n\r\n"; my $connected = 0; #----------------------------------------------------------------------- # Combo #0 - The user didn't specify a proxy #----------------------------------------------------------------------- if (!exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) && !exists($self->{SIDS}->{newconnection}->{httpsproxyhostname})) { $self->debug(1,"Connect: Combo #0: User did not specify a proxy... connecting DIRECT"); $self->debug(1,"Connect: Combo #0: Create normal socket"); $self->{SIDS}->{newconnection}->{sock} = new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{hostname}, PeerPort=>$self->{SIDS}->{newconnection}->{port}, Proto=>"tcp", (($timeout ne "") ? ( Timeout=>$timeout ) : ()), ); $connected = defined($self->{SIDS}->{newconnection}->{sock}); $self->debug(1,"Connect: Combo #0: connected($connected)"); # if ($connected) # { # $self->{SIDS}->{newconnection}->{sock}->syswrite($put,length($put),0); # my $buff; # $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ); # my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/); # $self->debug(1,"Connect: Combo #1: buff($buff)"); # $connected = 0 if ($code !~ /2\d\d/); # } # $self->debug(1,"Connect: Combo #0: connected($connected)"); } #----------------------------------------------------------------------- # Combo #1 - PUT through http_proxy #----------------------------------------------------------------------- if (!$connected && exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) && ($self->{SIDS}->{newconnection}->{ssl} == 0)) { $self->debug(1,"Connect: Combo #1: PUT through http_proxy"); $self->{SIDS}->{newconnection}->{sock} = new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpproxyhostname}, PeerPort=>$self->{SIDS}->{newconnection}->{httpproxyport}, Proto=>"tcp", (($timeout ne "") ? ( Timeout=>$timeout ) : ()), ); $connected = defined($self->{SIDS}->{newconnection}->{sock}); $self->debug(1,"Connect: Combo #1: connected($connected)"); if ($connected) { $self->debug(1,"Connect: Combo #1: send($put)"); $self->{SIDS}->{newconnection}->{sock}->syswrite($put,length($put),0); my $buff; $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ); my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/); $self->debug(1,"Connect: Combo #1: buff($buff)"); $connected = 0 if ($code !~ /2\d\d/); } $self->debug(1,"Connect: Combo #1: connected($connected)"); } #----------------------------------------------------------------------- # Combo #2 - CONNECT through http_proxy #----------------------------------------------------------------------- if (!$connected && exists($self->{SIDS}->{newconnection}->{httpproxyhostname}) && ($self->{SIDS}->{newconnection}->{ssl} == 0)) { $self->debug(1,"Connect: Combo #2: CONNECT through http_proxy"); $self->{SIDS}->{newconnection}->{sock} = new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpproxyhostname}, PeerPort=>$self->{SIDS}->{newconnection}->{httpproxyport}, Proto=>"tcp", (($timeout ne "") ? ( Timeout=>$timeout ) : ()), ); $connected = defined($self->{SIDS}->{newconnection}->{sock}); $self->debug(1,"Connect: Combo #2: connected($connected)"); if ($connected) { $self->{SIDS}->{newconnection}->{sock}->syswrite($connect,length($connect),0); my $buff; $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ); my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/); $self->debug(1,"Connect: Combo #2: buff($buff)"); $connected = 0 if ($code !~ /2\d\d/); } $self->debug(1,"Connect: Combo #2: connected($connected)"); } #----------------------------------------------------------------------- # Combo #3 - CONNECT through https_proxy #----------------------------------------------------------------------- if (!$connected && exists($self->{SIDS}->{newconnection}->{httpsproxyhostname})) { $self->debug(1,"Connect: Combo #3: CONNECT through https_proxy"); $self->{SIDS}->{newconnection}->{sock} = new IO::Socket::INET(PeerAddr=>$self->{SIDS}->{newconnection}->{httpsproxyhostname}, PeerPort=>$self->{SIDS}->{newconnection}->{httpsproxyport}, Proto=>"tcp"); $connected = defined($self->{SIDS}->{newconnection}->{sock}); $self->debug(1,"Connect: Combo #3: connected($connected)"); if ($connected) { $self->{SIDS}->{newconnection}->{sock}->syswrite($connect,length($connect),0); my $buff; $self->{SIDS}->{newconnection}->{sock}->sysread($buff,4*POSIX::BUFSIZ); my ($code) = ($buff =~ /^\S+\s+(\S+)\s+/); $self->debug(1,"Connect: Combo #3: buff($buff)"); $connected = 0 if ($code !~ /2\d\d/); } $self->debug(1,"Connect: Combo #3: connected($connected)"); } #----------------------------------------------------------------------- # We have failed #----------------------------------------------------------------------- if (!$connected) { $self->debug(1,"Connect: No connection... I have failed... I.. must... end it all..."); $self->SetErrorCode("newconnection","Unable to open a connection to destination. Please check your http_proxy and/or https_proxy environment variables."); return; } return unless $self->{SIDS}->{newconnection}->{sock}; $self->debug(1,"Connect: We are connected"); if (($self->{SIDS}->{newconnection}->{ssl} == 1) && (ref($self->{SIDS}->{newconnection}->{sock}) eq "IO::Socket::INET")) { $self->debug(1,"Connect: Convert normal socket to SSL"); $self->debug(1,"Connect: sock($self->{SIDS}->{newconnection}->{sock})"); $self->LoadSSL(); $self->{SIDS}->{newconnection}->{sock} = IO::Socket::SSL::socketToSSL($self->{SIDS}->{newconnection}->{sock}, {SSL_verify_mode=>0x00}); $self->debug(1,"Connect: ssl_sock($self->{SIDS}->{newconnection}->{sock})"); $self->debug(1,"Connect: SSL: We are secure") if ($self->{SIDS}->{newconnection}->{sock}); } return unless $self->{SIDS}->{newconnection}->{sock}; } $self->debug(1,"Connect: Got a connection"); $self->{SIDS}->{newconnection}->{sock}->autoflush(1); return $self->OpenStream("newconnection",$timeout); } ############################################################################## # # OpenStream - Send the opening stream and save the root element info. # ############################################################################## sub OpenStream { my $self = shift; my $currsid = shift; my $timeout = shift; $timeout = "" unless defined($timeout); $self->InitConnection($currsid,$currsid); #--------------------------------------------------------------------------- # Next, we build the opening handshake. #--------------------------------------------------------------------------- my %stream_args; if (($self->{SIDS}->{$currsid}->{connectiontype} eq "tcpip") || ($self->{SIDS}->{$currsid}->{connectiontype} eq "http")) { $stream_args{to}= $self->{SIDS}->{$currsid}->{hostname} unless exists($self->{SIDS}->{$currsid}->{to}); $stream_args{to} = $self->{SIDS}->{$currsid}->{to} if exists($self->{SIDS}->{$currsid}->{to}); $stream_args{from} = $self->{SIDS}->{$currsid}->{myhostname} if (!exists($self->{SIDS}->{$currsid}->{from}) && ($self->{SIDS}->{$currsid}->{myhostname} ne "") ); $stream_args{from} = $self->{SIDS}->{$currsid}->{from} if exists($self->{SIDS}->{$currsid}->{from}); $stream_args{id} = $self->{SIDS}->{$currsid}->{id} if (exists($self->{SIDS}->{$currsid}->{id}) && ($self->{SIDS}->{$currsid}->{id} ne "") ); $stream_args{namespaces} = $self->{SIDS}->{$currsid}->{namespaces}; } my $stream = $self->StreamHeader( xmlns=>$self->{SIDS}->{$currsid}->{namespace}, xmllang=>"en", %stream_args ); #--------------------------------------------------------------------------- # Create the XML::Stream::Parser and register our callbacks #--------------------------------------------------------------------------- $self->{SIDS}->{$currsid}->{parser} = new XML::Stream::Parser(%{$self->{DEBUGARGS}}, nonblocking=>$NONBLOCKING, sid=>$currsid, style=>$self->{DATASTYLE}, Handlers=>{ startElement=>sub{ $self->_handle_root(@_) }, endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) }, characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) }, } ); $self->{SIDS}->{$currsid}->{select} = new IO::Select($self->{SIDS}->{$currsid}->{sock}); if (($self->{SIDS}->{$currsid}->{connectiontype} eq "tcpip") || ($self->{SIDS}->{$currsid}->{connectiontype} eq "http")) { $self->{SELECT} = new IO::Select($self->{SIDS}->{$currsid}->{sock}); $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = "newconnection"; } if ($self->{SIDS}->{$currsid}->{connectiontype} eq "stdinout") { $self->{SELECT} = new IO::Select(*STDIN); $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $currsid; $self->{SOCKETS}->{*STDIN} = $currsid; $self->{SIDS}->{$currsid}->{select}->add(*STDIN); } $self->{SIDS}->{$currsid}->{status} = 0; #--------------------------------------------------------------------------- # Then we send the opening handshake. #--------------------------------------------------------------------------- $self->Send($currsid,$stream) || return; #--------------------------------------------------------------------------- # Before going on let's make sure that the server responded with a valid # root tag and that the stream is open. #--------------------------------------------------------------------------- my $buff = ""; my $timeEnd = ($timeout eq "") ? "" : time + $timeout; while($self->{SIDS}->{$currsid}->{status} == 0) { my $now = time; my $wait = (($timeEnd eq "") || ($timeEnd - $now > 10)) ? 10 : $timeEnd - $now; $self->debug(5,"Connect: can_read(",join(",",$self->{SIDS}->{$currsid}->{select}->can_read(0)),")"); if ($self->{SIDS}->{$currsid}->{select}->can_read($wait)) { $self->{SIDS}->{$currsid}->{status} = -1 unless defined($buff = $self->Read($currsid)); return unless($self->{SIDS}->{$currsid}->{status} == 0); return unless($self->ParseStream($currsid,$buff) == 1); } else { if ($timeout ne "") { if (time >= $timeEnd) { $self->SetErrorCode($currsid,"Timeout limit reached"); return; } } } return if($self->{SIDS}->{$currsid}->{select}->has_exception(0)); } return if($self->{SIDS}->{$currsid}->{status} != 1); $self->debug(3,"Connect: status($self->{SIDS}->{$currsid}->{status})"); my $sid = $self->GetRoot($currsid)->{id}; $| = 1; foreach my $key (keys(%{$self->{SIDS}->{$currsid}})) { $self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{$currsid}->{$key}; } $self->{SIDS}->{$sid}->{parser}->setSID($sid); if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") || ($self->{SIDS}->{$sid}->{connectiontype} eq "http")) { $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $sid; } if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout") { $self->{SOCKETS}->{$self->{SIDS}->{$currsid}->{sock}} = $sid; $self->{SOCKETS}->{*STDIN} = $sid; } delete($self->{SIDS}->{$currsid}) unless $currsid eq $sid; if (exists($self->GetRoot($sid)->{version}) && ($self->GetRoot($sid)->{version} ne "")) { while(!$self->ReceivedStreamFeatures($sid)) { $self->Process(1); } } return $self->GetRoot($sid); } ############################################################################## # # OpenFile - starts the stream by opening a file and setting it up so that # Process reads from the filehandle to get the incoming stream. # ############################################################################## sub OpenFile { my $self = shift; my $file = shift; $self->debug(1,"OpenFile: file($file)"); $self->{SIDS}->{newconnection}->{connectiontype} = "file"; $self->{SIDS}->{newconnection}->{sock} = new FileHandle($file); $self->{SIDS}->{newconnection}->{sock}->autoflush(1); $self->RegisterPrefix("newconnection",&ConstXMLNS("stream"),"stream"); #--------------------------------------------------------------------------- # Create the XML::Stream::Parser and register our callbacks #--------------------------------------------------------------------------- $self->{SIDS}->{newconnection}->{parser} = new XML::Stream::Parser(%{$self->{DEBUGARGS}}, nonblocking=>$NONBLOCKING, sid=>"newconnection", style=>$self->{DATASTYLE}, Handlers=>{ startElement=>sub{ $self->_handle_root(@_) }, endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) }, characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) }, } ); # select is not implemented for filehandles on win32 (see perlport) # so we fake it out using XML::Stream::IO::Select::Win32 if ( $^O =~ /mswin32/i ) { $self->{SIDS}->{newconnection}->{select} = new XML::Stream::IO::Select::Win32( $self->{SIDS}->{newconnection}->{sock}); $self->{SELECT} = new XML::Stream::IO::Select::Win32( $self->{SIDS}->{newconnection}->{sock}); } else { $self->{SIDS}->{newconnection}->{select} = new IO::Select($self->{SIDS}->{newconnection}->{sock}); $self->{SELECT} = new IO::Select($self->{SIDS}->{newconnection}->{sock}); } $self->{SIDS}->{newconnection}->{status} = 0; my $buff = ""; while($self->{SIDS}->{newconnection}->{status} == 0) { $self->debug(5,"OpenFile: can_read(",join(",",$self->{SIDS}->{newconnection}->{select}->can_read(0)),")"); if ($self->{SIDS}->{newconnection}->{select}->can_read(0)) { $self->{SIDS}->{newconnection}->{status} = -1 unless defined($buff = $self->Read("newconnection")); return unless($self->{SIDS}->{newconnection}->{status} == 0); return unless($self->ParseStream("newconnection",$buff) == 1); } return if($self->{SIDS}->{newconnection}->{select}->has_exception(0) && $self->{SIDS}->{newconnection}->{sock}->error()); } return if($self->{SIDS}->{newconnection}->{status} != 1); my $sid = $self->NewSID(); foreach my $key (keys(%{$self->{SIDS}->{newconnection}})) { $self->{SIDS}->{$sid}->{$key} = $self->{SIDS}->{newconnection}->{$key}; } $self->{SIDS}->{$sid}->{parser}->setSID($sid); $self->{SOCKETS}->{$self->{SIDS}->{newconnection}->{sock}} = $sid; delete($self->{SIDS}->{newconnection}); return $sid; } ############################################################################## #+---------------------------------------------------------------------------- #| #| Common Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # Disconnect - sends the closing XML tag and shuts down the socket. # ############################################################################## sub Disconnect { my $self = shift; my $sid = shift; $self->Send($sid,""); close($self->{SIDS}->{$sid}->{sock}) if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") || ($self->{SIDS}->{$sid}->{connectiontype} eq "http")); delete($self->{SOCKETS}->{$self->{SIDS}->{$sid}->{sock}}); foreach my $key (keys(%{$self->{SIDS}->{$sid}})) { delete($self->{SIDS}->{$sid}->{$key}); } delete($self->{SIDS}->{$sid}); } ############################################################################## # # InitConnection - Initialize the connection data structure # ############################################################################## sub InitConnection { my $self = shift; my $sid = shift; my $serverid = shift; #--------------------------------------------------------------------------- # Set the default STATUS so that we can keep track of it throughout the # session. # 1 = no errors # 0 = no data has been received yet # -1 = error from handlers # -2 = error but keep the connection alive so that we can send some info. #--------------------------------------------------------------------------- $self->{SIDS}->{$sid}->{status} = 0; #--------------------------------------------------------------------------- # A storage place for when we don't have a callback registered and we need # to stockpile the nodes we receive until Process is called and we return # them. #--------------------------------------------------------------------------- $self->{SIDS}->{$sid}->{nodes} = (); #--------------------------------------------------------------------------- # If there is an error on the stream, then we need a place to indicate that. #--------------------------------------------------------------------------- $self->{SIDS}->{$sid}->{streamerror} = {}; #--------------------------------------------------------------------------- # Grab the init time so that we can keep the connection alive by sending " " #--------------------------------------------------------------------------- $self->{SIDS}->{$sid}->{keepalive} = time; #--------------------------------------------------------------------------- # Keep track of the "server" we are connected to so we can check stuff # later. #--------------------------------------------------------------------------- $self->{SIDS}->{$sid}->{serverid} = $serverid; #--------------------------------------------------------------------------- # Mark the stream:features as MIA. #--------------------------------------------------------------------------- $self->{SIDS}->{$sid}->{streamfeatures}->{received} = 0; #--------------------------------------------------------------------------- # First acitivty is the connection... duh. =) #--------------------------------------------------------------------------- $self->MarkActivity($sid); } ############################################################################## # # ParseStream - takes the incoming stream and makes sure that only full # XML tags gets passed to the parser. If a full tag has not # read yet, then the Stream saves the incomplete part and # sends the rest to the parser. # ############################################################################## sub ParseStream { my $self = shift; my $sid = shift; my $stream = shift; $stream = "" unless defined($stream); $self->debug(3,"ParseStream: sid($sid) stream($stream)"); $self->{SIDS}->{$sid}->{parser}->parse($stream); if (exists($self->{SIDS}->{$sid}->{streamerror}->{type})) { $self->debug(3,"ParseStream: ERROR($self->{SIDS}->{$sid}->{streamerror}->{type})"); $self->SetErrorCode($sid,$self->{SIDS}->{$sid}->{streamerror}); return 0; } return 1; } ############################################################################## # # Process - checks for data on the socket and returns a status code depending # on if there was data or not. If a timeout is not defined in the # call then the timeout defined in Connect() is used. If a timeout # of 0 is used then the call blocks until it gets some data, # otherwise it returns after the timeout period. # ############################################################################## sub Process { my $self = shift; my $timeout = shift; $timeout = "" unless defined($timeout); $self->debug(4,"Process: timeout($timeout)"); #--------------------------------------------------------------------------- # We need to keep track of what's going on in the function and tell the # outside world about it so let's return something useful. We track this # information based on sid: # -1 connection closed and error # 0 connection open but no data received. # 1 connection open and data received. # array connection open and the data that has been collected # over time (No CallBack specified) #--------------------------------------------------------------------------- my %status; foreach my $sid (keys(%{$self->{SIDS}})) { next if ($sid eq "default"); $self->debug(5,"Process: initialize sid($sid) status to 0"); $status{$sid} = 0; } #--------------------------------------------------------------------------- # Either block until there is data and we have parsed it all, or wait a # certain period of time and then return control to the user. #--------------------------------------------------------------------------- my $block = 1; my $timeEnd = ($timeout eq "") ? "" : time + $timeout; while($block == 1) { $self->debug(4,"Process: let's wait for data"); my $now = time; my $wait = (($timeEnd eq "") || ($timeEnd - $now > 10)) ? 10 : $timeEnd - $now; foreach my $connection ($self->{SELECT}->can_read($wait)) { $self->debug(4,"Process: connection($connection)"); $self->debug(4,"Process: sid($self->{SOCKETS}->{$connection})"); $self->debug(4,"Process: connection_status($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status})"); next unless (($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{status} == 1) || exists($self->{SIDS}->{$self->{SOCKETS}->{$connection}}->{activitytimeout})); my $processit = 1; if (exists($self->{SIDS}->{server})) { foreach my $serverid (@{$self->{SIDS}->{server}}) { if (exists($self->{SIDS}->{$serverid}->{sock}) && ($connection == $self->{SIDS}->{$serverid}->{sock})) { my $sid = $self->ConnectionAccept($serverid); $status{$sid} = 0; $processit = 0; last; } } } if ($processit == 1) { my $sid = $self->{SOCKETS}->{$connection}; $self->debug(4,"Process: there's something to read"); $self->debug(4,"Process: connection($connection) sid($sid)"); my $buff; $self->debug(4,"Process: read"); $status{$sid} = 1; $self->{SIDS}->{$sid}->{status} = -1 if (!defined($buff = $self->Read($sid))); $buff = "" unless defined($buff); $self->debug(4,"Process: connection_status($self->{SIDS}->{$sid}->{status})"); $status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1); $self->debug(4,"Process: parse($buff)"); $status{$sid} = -1 unless($self->ParseStream($sid,$buff) == 1); } $block = 0; } if ($timeout ne "") { if (time >= $timeEnd) { $self->debug(4,"Process: Everyone out of the pool! Time to stop blocking."); $block = 0; } } $self->debug(4,"Process: timeout($timeout)"); if (exists($self->{CB}->{update})) { $self->debug(4,"Process: Calling user defined update function"); &{$self->{CB}->{update}}(); } $block = 1 if $self->{SELECT}->can_read(0); #--------------------------------------------------------------------- # Check for connections that need to be kept alive #--------------------------------------------------------------------- $self->debug(4,"Process: check for keepalives"); foreach my $sid (keys(%{$self->{SIDS}})) { next if ($sid eq "default"); next if ($sid =~ /^server/); next if ($status{$sid} == -1); if ((time - $self->{SIDS}->{$sid}->{keepalive}) > 10) { $self->IgnoreActivity($sid,1); $self->{SIDS}->{$sid}->{status} = -1 if !defined($self->Send($sid," ")); $status{$sid} = -1 unless($self->{SIDS}->{$sid}->{status} == 1); if ($status{$sid} == -1) { $self->debug(2,"Process: Keep-Alive failed. What the hell happened?!?!"); $self->debug(2,"Process: connection_status($self->{SIDS}->{$sid}->{status})"); } $self->IgnoreActivity($sid,0); } } #--------------------------------------------------------------------- # Check for connections that have timed out. #--------------------------------------------------------------------- $self->debug(4,"Process: check for timeouts"); foreach my $sid (keys(%{$self->{SIDS}})) { next if ($sid eq "default"); next if ($sid =~ /^server/); if (exists($self->{SIDS}->{$sid}->{activitytimeout})) { $self->debug(4,"Process: sid($sid) time(",time,") timeout($self->{SIDS}->{$sid}->{activitytimeout})"); } else { $self->debug(4,"Process: sid($sid) time(",time,") timeout(undef)"); } $self->Respond($sid) if (exists($self->{SIDS}->{$sid}->{activitytimeout}) && defined($self->GetRoot($sid))); $self->Disconnect($sid) if (exists($self->{SIDS}->{$sid}->{activitytimeout}) && ((time - $self->{SIDS}->{$sid}->{activitytimeout}) > 10) && ($self->{SIDS}->{$sid}->{status} != 1)); } #--------------------------------------------------------------------- # If any of the connections have status == -1 then return so that the # user can handle it. #--------------------------------------------------------------------- foreach my $sid (keys(%status)) { if ($status{$sid} == -1) { $self->debug(4,"Process: sid($sid) is broken... let's tell someone and watch it hit the fan... =)"); $block = 0; } } $self->debug(2,"Process: block($block)"); } #--------------------------------------------------------------------------- # If the Select has an error then shut this party down. #--------------------------------------------------------------------------- foreach my $connection ($self->{SELECT}->has_exception(0)) { $self->debug(4,"Process: has_exception sid($self->{SOCKETS}->{$connection})"); $status{$self->{SOCKETS}->{$connection}} = -1; } #--------------------------------------------------------------------------- # If there are data structures that have not been collected return # those, otherwise return the status which indicates if nodes were read or # not. #--------------------------------------------------------------------------- foreach my $sid (keys(%status)) { $status{$sid} = $self->{SIDS}->{$sid}->{nodes} if (($status{$sid} == 1) && ($#{$self->{SIDS}->{$sid}->{nodes}} > -1)); } return %status; } ############################################################################## # # Read - Takes the data from the server and returns a string # ############################################################################## sub Read { my $self = shift; my $sid = shift; my $buff; my $status = 1; $self->debug(3,"Read: sid($sid)"); $self->debug(3,"Read: connectionType($self->{SIDS}->{$sid}->{connectiontype})"); $self->debug(3,"Read: socket($self->{SIDS}->{$sid}->{sock})"); return if ($self->{SIDS}->{$sid}->{status} == -1); if (!defined($self->{SIDS}->{$sid}->{sock})) { $self->{SIDS}->{$sid}->{status} = -1; $self->SetErrorCode($sid,"Socket does not defined."); return; } $self->{SIDS}->{$sid}->{sock}->flush(); $status = $self->{SIDS}->{$sid}->{sock}->sysread($buff,4*POSIX::BUFSIZ) if (($self->{SIDS}->{$sid}->{connectiontype} eq "tcpip") || ($self->{SIDS}->{$sid}->{connectiontype} eq "http") || ($self->{SIDS}->{$sid}->{connectiontype} eq "file")); $status = sysread(STDIN,$buff,1024) if ($self->{SIDS}->{$sid}->{connectiontype} eq "stdinout"); $buff =~ s/^HTTP[\S\s]+\n\n// if ($self->{SIDS}->{$sid}->{connectiontype} eq "http"); $self->debug(1,"Read: buff($buff)"); $self->debug(3,"Read: status($status)") if defined($status); $self->debug(3,"Read: status(undef)") unless defined($status); $self->{SIDS}->{$sid}->{keepalive} = time unless (($buff eq "") || !defined($status) || ($status == 0)); if (defined($status) && ($status != 0)) { $buff = Encode::decode_utf8($buff); return $buff; } #return $buff unless (!defined($status) || ($status == 0)); $self->debug(1,"Read: ERROR"); return; } ############################################################################## # # Send - Takes the data string and sends it to the server # ############################################################################## sub Send { my $self = shift; my $sid = shift; $self->debug(1,"Send: (@_)"); $self->debug(3,"Send: sid($sid)"); $self->debug(3,"Send: status($self->{SIDS}->{$sid}->{status})"); $self->{SIDS}->{$sid}->{keepalive} = time; return if ($self->{SIDS}->{$sid}->{status} == -1); if (!defined($self->{SIDS}->{$sid}->{sock})) { $self->debug(3,"Send: socket not defined"); $self->{SIDS}->{$sid}->{status} = -1; $self->SetErrorCode($sid,"Socket not defined."); return; } else { $self->debug(3,"Send: socket($self->{SIDS}->{$sid}->{sock})"); } $self->{SIDS}->{$sid}->{sock}->flush(); if ($self->{SIDS}->{$sid}->{select}->can_write(0)) { $self->debug(3,"Send: can_write"); $self->{SENDSTRING} = Encode::encode_utf8(join("",@_)); $self->{SENDWRITTEN} = 0; $self->{SENDOFFSET} = 0; $self->{SENDLENGTH} = length($self->{SENDSTRING}); while ($self->{SENDLENGTH}) { $self->{SENDWRITTEN} = $self->{SIDS}->{$sid}->{sock}->syswrite($self->{SENDSTRING},$self->{SENDLENGTH},$self->{SENDOFFSET}); if (!defined($self->{SENDWRITTEN})) { $self->debug(4,"Send: SENDWRITTEN(undef)"); $self->debug(4,"Send: Ok... what happened? Did we lose the connection?"); $self->{SIDS}->{$sid}->{status} = -1; $self->SetErrorCode($sid,"Socket died for an unknown reason."); return; } $self->debug(4,"Send: SENDWRITTEN($self->{SENDWRITTEN})"); $self->{SENDLENGTH} -= $self->{SENDWRITTEN}; $self->{SENDOFFSET} += $self->{SENDWRITTEN}; } } else { $self->debug(3,"Send: can't write..."); } return if($self->{SIDS}->{$sid}->{select}->has_exception(0)); $self->debug(3,"Send: no exceptions"); $self->{SIDS}->{$sid}->{keepalive} = time; $self->MarkActivity($sid); return 1; } ############################################################################## #+---------------------------------------------------------------------------- #| #| Feature Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # ProcessStreamFeatures - process the block. # ############################################################################## sub ProcessStreamFeatures { my $self = shift; my $sid = shift; my $node = shift; $self->{SIDS}->{$sid}->{streamfeatures}->{received} = 1; #------------------------------------------------------------------------- # SASL - 1.0 #------------------------------------------------------------------------- my @sasl = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-sasl').'"]'); if ($#sasl > -1) { if (&XPath($sasl[0],"name()") eq "mechanisms") { my @mechanisms = &XPath($sasl[0],"mechanism/text()"); $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-sasl'} = \@mechanisms; } } #------------------------------------------------------------------------- # XMPP-TLS - 1.0 #------------------------------------------------------------------------- my @tls = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-tls').'"]'); if ($#tls > -1) { if (&XPath($tls[0],"name()") eq "starttls") { $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = 1; my @required = &XPath($tls[0],"required"); if ($#required > -1) { $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-tls'} = "required"; } } } #------------------------------------------------------------------------- # XMPP-Bind - 1.0 #------------------------------------------------------------------------- my @bind = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-bind').'"]'); if ($#bind > -1) { $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-bind'} = 1; } #------------------------------------------------------------------------- # XMPP-Session - 1.0 #------------------------------------------------------------------------- my @session = &XPath($node,'*[@xmlns="'.&ConstXMLNS('xmpp-session').'"]'); if ($#session > -1) { $self->{SIDS}->{$sid}->{streamfeatures}->{'xmpp-session'} = 1; } } ############################################################################## # # GetStreamFeature - Return the value of the stream feature (if any). # ############################################################################## sub GetStreamFeature { my $self = shift; my $sid = shift; my $feature = shift; return unless exists($self->{SIDS}->{$sid}->{streamfeatures}->{$feature}); return $self->{SIDS}->{$sid}->{streamfeatures}->{$feature}; } ############################################################################## # # ReceivedStreamFeatures - Have we received the stream:features yet? # ############################################################################## sub ReceivedStreamFeatures { my $self = shift; my $sid = shift; my $feature = shift; return $self->{SIDS}->{$sid}->{streamfeatures}->{received}; } ############################################################################## #+---------------------------------------------------------------------------- #| #| TLS Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # ProcessTLSPacket - process a TLS based packet. # ############################################################################## sub ProcessTLSPacket { my $self = shift; my $sid = shift; my $node = shift; my $tag = &XPath($node,"name()"); if ($tag eq "failure") { $self->TLSClientFailure($sid,$node); } if ($tag eq "proceed") { $self->TLSClientProceed($sid,$node); } } ############################################################################## # # StartTLS - client function to have the socket start TLS. # ############################################################################## sub StartTLS { my $self = shift; my $sid = shift; my $timeout = shift; $timeout = 120 unless defined($timeout); $timeout = 120 if ($timeout eq ""); $self->TLSStartTLS($sid); my $endTime = time + $timeout; while(!$self->TLSClientDone($sid) && ($endTime >= time)) { $self->Process(1); } if (!$self->TLSClientSecure($sid)) { return; } return $self->OpenStream($sid,$timeout); } ############################################################################## # # TLSStartTLS - send a in the TLS namespace. # ############################################################################## sub TLSStartTLS { my $self = shift; my $sid = shift; $self->Send($sid,""); } ############################################################################## # # TLSClientProceed - handle a packet. # ############################################################################## sub TLSClientProceed { my $self = shift; my $sid = shift; my $node = shift; $self->debug(1,"TLSClientProceed: Convert normal socket to SSL"); $self->debug(1,"TLSClientProceed: sock($self->{SIDS}->{$sid}->{sock})"); if (!$self->LoadSSL()) { $self->{SIDS}->{$sid}->{tls}->{error} = "Could not load IO::Socket::SSL."; $self->{SIDS}->{$sid}->{tls}->{done} = 1; return; } IO::Socket::SSL->start_SSL($self->{SIDS}->{$sid}->{sock},{SSL_verify_mode=>0x00}); $self->debug(1,"TLSClientProceed: ssl_sock($self->{SIDS}->{$sid}->{sock})"); $self->debug(1,"TLSClientProceed: SSL: We are secure") if ($self->{SIDS}->{$sid}->{sock}); $self->{SIDS}->{$sid}->{tls}->{done} = 1; $self->{SIDS}->{$sid}->{tls}->{secure} = 1; } ############################################################################## # # TLSClientSecure - return 1 if the socket is secure, 0 otherwise. # ############################################################################## sub TLSClientSecure { my $self = shift; my $sid = shift; return $self->{SIDS}->{$sid}->{tls}->{secure}; } ############################################################################## # # TLSClientDone - return 1 if the TLS process is done # ############################################################################## sub TLSClientDone { my $self = shift; my $sid = shift; return $self->{SIDS}->{$sid}->{tls}->{done}; } ############################################################################## # # TLSClientError - return the TLS error if any # ############################################################################## sub TLSClientError { my $self = shift; my $sid = shift; return $self->{SIDS}->{$sid}->{tls}->{error}; } ############################################################################## # # TLSClientFailure - handle a # ############################################################################## sub TLSClientFailure { my $self = shift; my $sid = shift; my $node = shift; my $type = &XPath($node,"*/name()"); $self->{SIDS}->{$sid}->{tls}->{error} = $type; $self->{SIDS}->{$sid}->{tls}->{done} = 1; } ############################################################################## # # TLSFailure - Send a in the TLS namespace # ############################################################################## sub TLSFailure { my $self = shift; my $sid = shift; my $type = shift; $self->Send($sid,"<${type}/>"); } ############################################################################## #+---------------------------------------------------------------------------- #| #| SASL Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # ProcessSASLPacket - process a SASL based packet. # ############################################################################## sub ProcessSASLPacket { my $self = shift; my $sid = shift; my $node = shift; my $tag = &XPath($node,"name()"); if ($tag eq "challenge") { $self->SASLAnswerChallenge($sid,$node); } if ($tag eq "failure") { $self->SASLClientFailure($sid,$node); } if ($tag eq "success") { $self->SASLClientSuccess($sid,$node); } } ############################################################################## # # SASLAnswerChallenge - when we get a we need to do the grunt # work to return a . # ############################################################################## sub SASLAnswerChallenge { my $self = shift; my $sid = shift; my $node = shift; my $challenge64 = &XPath($node,"text()"); my $challenge = MIME::Base64::decode_base64($challenge64); #------------------------------------------------------------------------- # As far as I can tell, if the challenge contains rspauth, then we authed. # If you try to send that to Authen::SASL, it will spew warnings about # the missing qop, nonce, etc... However, in order for jabberd2 to think # that you answered, you have to send back an empty response. Not sure # which approach is right... So let's hack for now. #------------------------------------------------------------------------- my $response = ""; if ($challenge !~ /rspauth\=/) { $response = $self->{SIDS}->{$sid}->{sasl}->{client}->client_step($challenge); } my $response64 = MIME::Base64::encode_base64($response,""); $self->SASLResponse($sid,$response64); } ############################################################################## # # SASLAuth - send an in the SASL namespace # ############################################################################## 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.""); } ############################################################################## # # SASLChallenge - Send a in the SASL namespace # ############################################################################## sub SASLChallenge { my $self = shift; my $sid = shift; my $challenge = shift; $self->Send($sid,"${challenge}"); } ############################################################################### # # SASLClient - This is a helper function to perform all of the required steps # for doing SASL with the server. # ############################################################################### sub SASLClient { my $self = shift; my $sid = shift; my $username = shift; my $password = shift; my $mechanisms = $self->GetStreamFeature($sid,"xmpp-sasl"); return unless defined($mechanisms); # Here we assume that if 'to' is available, then a domain is being # specified that does not match the hostname of the jabber server # and that we should use that to form the bare JID for SASL auth. my $domain .= $self->{SIDS}->{$sid}->{to} ? $self->{SIDS}->{$sid}->{to} : $self->{SIDS}->{$sid}->{hostname}; my $authname = $username . '@' . $domain; my $sasl = new Authen::SASL(mechanism=>join(" ",@{$mechanisms}), callback=>{ authname => $authname, user => $username, pass => $password } ); $self->{SIDS}->{$sid}->{sasl}->{client} = $sasl->client_new('xmpp', $domain); $self->{SIDS}->{$sid}->{sasl}->{username} = $username; $self->{SIDS}->{$sid}->{sasl}->{password} = $password; $self->{SIDS}->{$sid}->{sasl}->{authed} = 0; $self->{SIDS}->{$sid}->{sasl}->{done} = 0; $self->SASLAuth($sid); } ############################################################################## # # SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise # ############################################################################## sub SASLClientAuthed { my $self = shift; my $sid = shift; return $self->{SIDS}->{$sid}->{sasl}->{authed}; } ############################################################################## # # SASLClientDone - return 1 if the SASL process is finished # ############################################################################## sub SASLClientDone { my $self = shift; my $sid = shift; return $self->{SIDS}->{$sid}->{sasl}->{done}; } ############################################################################## # # SASLClientError - return the error if any # ############################################################################## sub SASLClientError { my $self = shift; my $sid = shift; return $self->{SIDS}->{$sid}->{sasl}->{error}; } ############################################################################## # # SASLClientFailure - handle a received # ############################################################################## sub SASLClientFailure { my $self = shift; my $sid = shift; my $node = shift; my $type = &XPath($node,"*/name()"); $self->{SIDS}->{$sid}->{sasl}->{error} = $type; $self->{SIDS}->{$sid}->{sasl}->{done} = 1; } ############################################################################## # # SASLClientSuccess - handle a received # ############################################################################## sub SASLClientSuccess { my $self = shift; my $sid = shift; my $node = shift; $self->{SIDS}->{$sid}->{sasl}->{authed} = 1; $self->{SIDS}->{$sid}->{sasl}->{done} = 1; } ############################################################################## # # SASLFailure - Send a tag in the SASL namespace # ############################################################################## sub SASLFailure { my $self = shift; my $sid = shift; my $type = shift; $self->Send($sid,"<${type}/>"); } ############################################################################## # # SASLResponse - Send a tag in the SASL namespace # ############################################################################## sub SASLResponse { my $self = shift; my $sid = shift; my $response = shift; $self->Send($sid,"${response}"); } ############################################################################## #+---------------------------------------------------------------------------- #| #| Packet Handlers #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # ProcessStreamPacket - process the packet # ############################################################################## sub ProcessStreamPacket { my $self = shift; my $sid = shift; my $node = shift; my $tag = &XPath($node,"name()"); my $stream_prefix = $self->StreamPrefix($sid); my ($type) = ($tag =~ /^${stream_prefix}\:(.+)$/); $self->ProcessStreamError($sid,$node) if ($type eq "error"); $self->ProcessStreamFeatures($sid,$node) if ($type eq "features"); } ############################################################################## # # _handle_root - handles a root tag and checks that it is a stream:stream tag # with the proper namespace. If not then it sets the STATUS # to -1 and let's the outer code know that an error occurred. # Then it changes the Start tag handlers to the methond listed # in $self->{DATASTYLE} # ############################################################################## sub _handle_root { my $self = shift; my ($sax, $tag, %att) = @_; my $sid = $sax->getSID(); $self->debug(2,"_handle_root: sid($sid) sax($sax) tag($tag) att(",%att,")"); $self->{SIDS}->{$sid}->{rootTag} = $tag; if ($self->{SIDS}->{$sid}->{connectiontype} ne "file") { #--------------------------------------------------------------------- # Make sure we are receiving a valid stream on the same namespace. #--------------------------------------------------------------------- $self->debug(3,"_handle_root: ($self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace})"); $self->{SIDS}->{$sid}->{status} = ((($tag eq "stream:stream") && exists($att{'xmlns'}) && ($att{'xmlns'} eq $self->{SIDS}->{$self->{SIDS}->{$sid}->{serverid}}->{namespace}) ) ? 1 : -1 ); $self->debug(3,"_handle_root: status($self->{SIDS}->{$sid}->{status})"); } else { $self->{SIDS}->{$sid}->{status} = 1; } #------------------------------------------------------------------------- # Get the root tag attributes and save them for later. You never know when # you'll need to check the namespace or the from attributes sent by the # server. #------------------------------------------------------------------------- $self->{SIDS}->{$sid}->{root} = \%att; #------------------------------------------------------------------------- # Run through the various xmlns:*** attributes and register the namespace # to prefix map. #------------------------------------------------------------------------- foreach my $key (keys(%att)) { if ($key =~ /^xmlns\:(.+?)$/) { $self->debug(5,"_handle_root: RegisterPrefix: prefix($att{$key}) ns($1)"); $self->RegisterPrefix($sid,$att{$key},$1); } } #------------------------------------------------------------------------- # Sometimes we will get an error, so let's parse the tag assuming that we # got a stream:error #------------------------------------------------------------------------- my $stream_prefix = $self->StreamPrefix($sid); $self->debug(5,"_handle_root: stream_prefix($stream_prefix)"); if ($tag eq $stream_prefix.":error") { &XML::Stream::Tree::_handle_element($self,$sax,$tag,%att) if ($self->{DATASTYLE} eq "tree"); &XML::Stream::Node::_handle_element($self,$sax,$tag,%att) if ($self->{DATASTYLE} eq "node"); } #--------------------------------------------------------------------------- # Now that we have gotten a root tag, let's look for the tags that make up # the stream. Change the handler for a Start tag to another function. #--------------------------------------------------------------------------- $sax->setHandlers(startElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{startElement}}($self,@_) }, endElement=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{endElement}}($self,@_) }, characters=>sub{ &{$HANDLERS{$self->{DATASTYLE}}->{characters}}($self,@_) }, ); } ############################################################################## # # _node - internal callback for nodes. All it does is place the nodes in a # list so that Process() can return them later. # ############################################################################## sub _node { my $self = shift; my $sid = shift; my @node = shift; if (ref($node[0]) eq "XML::Stream::Node") { push(@{$self->{SIDS}->{$sid}->{nodes}},$node[0]); } else { push(@{$self->{SIDS}->{$sid}->{nodes}},\@node); } } ############################################################################## #+---------------------------------------------------------------------------- #| #| Error Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # GetErrorCode - if you are returned an undef, you can call this function # and hopefully learn more information about the problem. # ############################################################################## sub GetErrorCode { my $self = shift; my $sid = shift; $sid = "newconnection" unless defined($sid); $self->debug(3,"GetErrorCode: sid($sid)"); return ((exists($self->{SIDS}->{$sid}->{errorcode}) && (ref($self->{SIDS}->{$sid}->{errorcode}) eq "HASH")) ? $self->{SIDS}->{$sid}->{errorcode} : { type=>"system", text=>$!, } ); } ############################################################################## # # SetErrorCode - sets the error code so that the caller can find out more # information about the problem # ############################################################################## sub SetErrorCode { my $self = shift; my $sid = shift; my $errorcode = shift; $self->{SIDS}->{$sid}->{errorcode} = $errorcode; } ############################################################################## # # ProcessStreamError - Take the XML packet and extract out the error. # ############################################################################## sub ProcessStreamError { my $self = shift; my $sid = shift; my $node = shift; $self->{SIDS}->{$sid}->{streamerror}->{type} = "unknown"; $self->{SIDS}->{$sid}->{streamerror}->{node} = $node; #------------------------------------------------------------------------- # Check for older 0.9 streams and handle the errors for them. #------------------------------------------------------------------------- if (!exists($self->{SIDS}->{$sid}->{root}->{version}) || ($self->{SIDS}->{$sid}->{root}->{version} eq "") || ($self->{SIDS}->{$sid}->{root}->{version} < 1.0) ) { $self->{SIDS}->{$sid}->{streamerror}->{text} = &XPath($node,"text()"); return; } #------------------------------------------------------------------------- # Otherwise we are in XMPP land with real stream errors. #------------------------------------------------------------------------- my @errors = &XPath($node,'*[@xmlns="'.&ConstXMLNS("xmppstreams").'"]'); my $type; my $text; foreach my $error (@errors) { if (&XPath($error,"name()") eq "text") { $self->{SIDS}->{$sid}->{streamerror}->{text} = &XPath($error,"text()"); } else { $self->{SIDS}->{$sid}->{streamerror}->{type} = &XPath($error,"name()"); } } } ############################################################################## # # StreamError - Given a type and text, generate a packet to # send back to the other side. # ############################################################################## sub StreamError { my $self = shift; my $sid = shift; my $type = shift; my $text = shift; my $root = $self->GetRoot($sid); my $stream_base = $self->StreamPrefix($sid); my $error = "<${stream_base}:error>"; if (exists($root->{version}) && ($root->{version} ne "")) { $error .= "<${type} xmlns='".&ConstXMLNS('xmppstreams')."'/>"; if (defined($text)) { $error .= ""; $error .= $text; $error .= ""; } } else { $error .= $text; } $error .= ""; return $error; } ############################################################################## #+---------------------------------------------------------------------------- #| #| Activity Monitoring Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # IgnoreActivity - Set the flag that will ignore the activity monitor. # ############################################################################## sub IgnoreActivity { my $self = shift; my $sid = shift; my $ignoreActivity = shift; $ignoreActivity = 1 unless defined($ignoreActivity); $self->debug(3,"IgnoreActivity: ignoreActivity($ignoreActivity)"); $self->debug(4,"IgnoreActivity: sid($sid)"); $self->{SIDS}->{$sid}->{ignoreActivity} = $ignoreActivity; } ############################################################################## # # LastActivity - Return the time of the last activity. # ############################################################################## sub LastActivity { my $self = shift; my $sid = shift; $self->debug(3,"LastActivity: sid($sid)"); $self->debug(1,"LastActivity: lastActivity($self->{SIDS}->{$sid}->{lastActivity})"); return $self->{SIDS}->{$sid}->{lastActivity}; } ############################################################################## # # MarkActivity - Record the current time for this sid. # ############################################################################## sub MarkActivity { my $self = shift; my $sid = shift; return if (exists($self->{SIDS}->{$sid}->{ignoreActivity}) && ($self->{SIDS}->{$sid}->{ignoreActivity} == 1)); $self->debug(3,"MarkActivity: sid($sid)"); $self->{SIDS}->{$sid}->{lastActivity} = time; } ############################################################################## #+---------------------------------------------------------------------------- #| #| XML Node Interface functions #| #| These are generic wrappers around the Tree and Node data types. The #| problem being that the Tree class cannot support methods. #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # SetXMLData - takes a host of arguments and sets a portion of the specified # data strucure with that data. The function works in two # modes "single" or "multiple". "single" denotes that the # function should locate the current tag that matches this # data and overwrite it's contents with data passed in. # "multiple" denotes that a new tag should be created even if # others exist. # # type - single or multiple # XMLTree - pointer to XML::Stream data object (tree or node) # tag - name of tag to create/modify (if blank assumes # working with top level tag) # data - CDATA to set for tag # attribs - attributes to ADD to tag # ############################################################################## sub SetXMLData { return &XML::Stream::Node::SetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node"); return &XML::Stream::Tree::SetXMLData(@_) if (ref($_[1]) eq "ARRAY"); } ############################################################################## # # GetXMLData - takes a host of arguments and returns various data structures # that match them. # # type - "existence" - returns 1 or 0 if the tag exists in the # top level. # "value" - returns either the CDATA of the tag, or the # value of the attribute depending on which is # sought. This ignores any mark ups to the data # and just returns the raw CDATA. # "value array" - returns an array of strings representing # all of the CDATA in the specified tag. # This ignores any mark ups to the data # and just returns the raw CDATA. # "tree" - returns a data structure that represents the # XML with the specified tag as the root tag. # Depends on the format that you are working with. # "tree array" - returns an array of data structures each # with the specified tag as the root tag. # "child array" - returns a list of all children nodes # not including CDATA nodes. # "attribs" - returns a hash with the attributes, and # their values, for the things that match # the parameters # "count" - returns the number of things that match # the arguments # "tag" - returns the root tag of this tree # XMLTree - pointer to XML::Stream data structure # tag - tag to pull data from. If blank then the top level # tag is accessed. # attrib - attribute value to retrieve. Ignored for types # "value array", "tree", "tree array". If paired # with value can be used to filter tags based on # attributes and values. # value - only valid if an attribute is supplied. Used to # filter for tags that only contain this attribute. # Useful to search through multiple tags that all # reference different name spaces. # ############################################################################## sub GetXMLData { return &XML::Stream::Node::GetXMLData(@_) if (ref($_[1]) eq "XML::Stream::Node"); return &XML::Stream::Tree::GetXMLData(@_) if (ref($_[1]) eq "ARRAY"); } ############################################################################## # # XPath - run an xpath query on a node and return back the result. # ############################################################################## sub XPath { my $tree = shift; my $path = shift; my $query = new XML::Stream::XPath::Query($path); my $result = $query->execute($tree); if ($result->check()) { my %attribs = $result->getAttribs(); return %attribs if (scalar(keys(%attribs)) > 0); my @values = $result->getValues(); @values = $result->getList() unless ($#values > -1); return @values if wantarray; return $values[0]; } return; } ############################################################################## # # XPathCheck - run an xpath query on a node and return 1 or 0 if the path is # valid. # ############################################################################## sub XPathCheck { my $tree = shift; my $path = shift; my $query = new XML::Stream::XPath::Query($path); my $result = $query->execute($tree); return $result->check(); } ############################################################################## # # XML2Config - takes an XML data tree and turns it into a hash of hashes. # This only works for certain kinds of XML trees like this: # # # 1 # # foo # # 5 # 6 # # # The resulting hash would be: # # $hash{bar} = 1; # $hash{x}->{y} = "foo"; # $hash{z}->[0] = 5; # $hash{z}->[1] = 6; # # Good for config files. # ############################################################################## sub XML2Config { return &XML::Stream::Node::XML2Config(@_) if (ref($_[0]) eq "XML::Stream::Node"); return &XML::Stream::Tree::XML2Config(@_) if (ref($_[0]) eq "ARRAY"); } ############################################################################## # # Config2XML - takes a hash and produces an XML string from it. If the hash # looks like this: # # $hash{bar} = 1; # $hash{x}->{y} = "foo"; # $hash{z}->[0] = 5; # $hash{z}->[1] = 6; # # The resulting xml would be: # # # 1 # # foo # # 5 # 6 # # # Good for config files. # ############################################################################## sub Config2XML { my ($tag,$hash,$indent) = @_; $indent = "" unless defined($indent); my $xml; if (ref($hash) eq "ARRAY") { foreach my $item (@{$hash}) { $xml .= &XML::Stream::Config2XML($tag,$item,$indent); } } else { if ((ref($hash) eq "HASH") && ((scalar keys(%{$hash})) == 0)) { $xml .= "$indent<$tag/>\n"; } else { if (ref($hash) eq "") { if ($hash eq "") { return "$indent<$tag/>\n"; } else { return "$indent<$tag>$hash\n"; } } else { $xml .= "$indent<$tag>\n"; foreach my $item (sort {$a cmp $b} keys(%{$hash})) { $xml .= &XML::Stream::Config2XML($item,$hash->{$item}," $indent"); } $xml .= "$indent\n"; } } } return $xml; } ############################################################################## # # EscapeXML - Simple function to make sure that no bad characters make it into # in the XML string that might cause the string to be # misinterpreted. # ############################################################################## sub EscapeXML { my $data = shift; if (defined($data)) { $data =~ s/&/&/g; $data =~ s//>/g; $data =~ s/\"/"/g; $data =~ s/\'/'/g; } return $data; } ############################################################################## # # UnescapeXML - Simple function to take an escaped string and return it to # normal. # ############################################################################## sub UnescapeXML { my $data = shift; if (defined($data)) { $data =~ s/&/&/g; $data =~ s/<//g; $data =~ s/"/\"/g; $data =~ s/'/\'/g; } return $data; } ############################################################################## # # BuildXML - takes one of the data formats that XML::Stream supports and call # the proper BuildXML_xxx function on it. # ############################################################################## sub BuildXML { return &XML::Stream::Node::BuildXML(@_) if (ref($_[0]) eq "XML::Stream::Node"); return &XML::Stream::Tree::BuildXML(@_) if (ref($_[0]) eq "ARRAY"); return &XML::Stream::Tree::BuildXML(@_) if (ref($_[1]) eq "ARRAY"); } ############################################################################## #+---------------------------------------------------------------------------- #| #| Namespace/Prefix Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # ConstXMLNS - Return the namespace from the constant string. # ############################################################################## sub ConstXMLNS { my $const = shift; return $XMLNS{$const}; } ############################################################################## # # StreamPrefix - Return the prefix of the # ############################################################################## sub StreamPrefix { my $self = shift; my $sid = shift; return $self->ns2prefix($sid,&ConstXMLNS("stream")); } ############################################################################## # # RegisterPrefix - setup the map for namespace to prefix # ############################################################################## sub RegisterPrefix { my $self = shift; my $sid = shift; my $ns = shift; my $prefix = shift; $self->{SIDS}->{$sid}->{ns2prefix}->{$ns} = $prefix; } ############################################################################## # # ns2prefix - for a stream, return the prefix for the given namespace # ############################################################################## sub ns2prefix { my $self = shift; my $sid = shift; my $ns = shift; return $self->{SIDS}->{$sid}->{ns2prefix}->{$ns}; } ############################################################################## #+---------------------------------------------------------------------------- #| #| Helper Functions #| #+---------------------------------------------------------------------------- ############################################################################## ############################################################################## # # GetRoot - returns the hash of attributes for the root tag # so that any attributes returned can be accessed. from and any # xmlns:foobar might be important. # ############################################################################## sub GetRoot { my $self = shift; my $sid = shift; return unless exists($self->{SIDS}->{$sid}->{root}); return $self->{SIDS}->{$sid}->{root}; } ############################################################################## # # GetSock - returns the Socket so that an outside function can access it if # desired. # ############################################################################## sub GetSock { my $self = shift; my $sid = shift; return $self->{SIDS}->{$sid}->{sock}; } ############################################################################## # # LoadSSL - simple call to set everything up for SSL one time. # ############################################################################## sub LoadSSL { my $self = shift; $self->debug(1,"LoadSSL: Load the IO::Socket::SSL module"); if (defined($SSL) && ($SSL == 1)) { $self->debug(1,"LoadSSL: Success"); return 1; } if (defined($SSL) && ($SSL == 0)) { $self->debug(1,"LoadSSL: Failure"); return; } my $SSL_Version = "0.81"; eval "use IO::Socket::SSL $SSL_Version"; if ($@) { croak("You requested that XML::Stream turn the socket into an SSL socket, but you don't have the correct version of IO::Socket::SSL v$SSL_Version."); } IO::Socket::SSL::context_init({SSL_verify_mode=>0x00}); $SSL = 1; $self->debug(1,"LoadSSL: Success"); return 1; } ############################################################################## # # Host2SID - For a server this allows you to lookup the SID of a stream server # based on the hostname that is is listening on. # ############################################################################## sub Host2SID { my $self = shift; my $hostname = shift; foreach my $sid (keys(%{$self->{SIDS}})) { next if ($sid eq "default"); next if ($sid =~ /^server/); return $sid if ($self->{SIDS}->{$sid}->{hostname} eq $hostname); } return; } ############################################################################## # # NewSID - returns a session ID to send to an incoming stream in the return # header. By default it just increments a counter and returns that, # or you can define a function and set it using the SetCallBacks # function. # ############################################################################## sub NewSID { my $self = shift; return &{$self->{CB}->{sid}}() if (exists($self->{CB}->{sid}) && defined($self->{CB}->{sid})); return $$.time.$self->{IDCOUNT}++; } ########################################################################### # # SetCallBacks - Takes a hash with top level tags to look for as the keys # and pointers to functions as the values. # ########################################################################### sub SetCallBacks { my $self = shift; while($#_ >= 0) { my $func = pop(@_); my $tag = pop(@_); if (($tag eq "node") && !defined($func)) { $self->SetCallBacks(node=>sub { $self->_node(@_) }); } else { $self->debug(1,"SetCallBacks: tag($tag) func($func)"); $self->{CB}->{$tag} = $func; } } } ############################################################################## # # StreamHeader - Given the arguments, return the opening stream header. # ############################################################################## sub StreamHeader { my $self = shift; my (%args) = @_; my $stream; $stream .= ""; $stream .= "GetStream(); } $stream .= ">"; return $stream; } ########################################################################### # # debug - prints the arguments to the debug log if debug is turned on. # ########################################################################### sub debug { return if ($_[1] > $_[0]->{DEBUGLEVEL}); my $self = shift; my ($limit,@args) = @_; return if ($self->{DEBUGFILE} eq ""); my $fh = $self->{DEBUGFILE}; if ($self->{DEBUGTIME} == 1) { my ($sec,$min,$hour) = localtime(time); print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec); } print $fh "XML::Stream: @args\n"; } ############################################################################## # # nonblock - set the socket to be non-blocking. # ############################################################################## sub nonblock { my $self = shift; my $socket = shift; #-------------------------------------------------------------------------- # Code copied from POE::Wheel::SocketFactory... # Win32 does things one way... #-------------------------------------------------------------------------- if ($^O eq "MSWin32") { ioctl( $socket, 0x80000000 | (4 << 16) | (ord('f') << 8) | 126, 1) || croak("Can't make socket nonblocking (win32): $!"); return; } #-------------------------------------------------------------------------- # And UNIX does them another #-------------------------------------------------------------------------- my $flags = fcntl($socket, F_GETFL, 0) or die "Can't get flags for socket: $!\n"; fcntl($socket, F_SETFL, $flags | O_NONBLOCK) or die "Can't make socket nonblocking: $!\n"; } ############################################################################## # # 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 { my ($preString,$data) = @_; my $outString = ""; if (ref($data) eq "HASH") { my $key; foreach $key (sort { $a cmp $b } keys(%{$data})) { if (ref($$data{$key}) eq "") { my $value = defined($$data{$key}) ? $$data{$key} : ""; $outString .= $preString."{'$key'} = \"".$value."\";\n"; } else { if (ref($$data{$key}) =~ /Net::Jabber/) { $outString .= $preString."{'$key'} = ".ref($$data{$key}).";\n"; } else { $outString .= $preString."{'$key'};\n"; $outString .= &sprintData($preString."{'$key'}->",$$data{$key}); } } } } else { if (ref($data) eq "ARRAY") { my $index; foreach $index (0..$#{$data}) { if (ref($$data[$index]) eq "") { $outString .= $preString."[$index] = \"$$data[$index]\";\n"; } else { if (ref($$data[$index]) =~ /Net::Jabber/) { $outString .= $preString."[$index] = ".ref($$data[$index]).";\n"; } else { $outString .= $preString."[$index];\n"; $outString .= &sprintData($preString."[$index]->",$$data[$index]); } } } } else { if (ref($data) eq "REF") { $outString .= &sprintData($preString."->",$$data); } else { if (ref($data) eq "") { $outString .= $preString." = \"$data\";\n"; } else { $outString .= $preString." = ".ref($data).";\n"; } } } } return $outString; } 1; XML-Stream-1.23/lib/XML/Stream/0000755000175000017500000000000011321531273016455 5ustar dapatrickdapatrickXML-Stream-1.23/lib/XML/Stream/IO/0000755000175000017500000000000011321531273016764 5ustar dapatrickdapatrickXML-Stream-1.23/lib/XML/Stream/IO/Select/0000755000175000017500000000000011321531273020203 5ustar dapatrickdapatrickXML-Stream-1.23/lib/XML/Stream/IO/Select/Win32.pm0000644000175000017500000000060411321523765021452 0ustar dapatrickdapatrickpackage XML::Stream::IO::Select::Win32; =head1 NAME XML::Stream::IO::Select::Win32 - Fake filehandle support for XML::Stream =head1 SYNOPSIS You should have no reason to use this directly. =cut use strict; use warnings; use vars qw( $VERSION ); $VERSION = "1.23"; use base 'IO::Select'; sub can_read { my $vec = shift; my $timeout = shift; $vec->handles(); } 1; XML-Stream-1.23/lib/XML/Stream/Namespace.pm0000644000175000017500000001025711321524530020712 0ustar dapatrickdapatrick############################################################################## # # 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. # # Jabber # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package XML::Stream::Namespace; =head1 NAME XML::Stream::Namespace - Object to make defining Namespaces easier in XML::Stream. =head1 SYNOPSIS XML::Stream::Namespace is a helper package to XML::Stream. It provides a clean way of defining Namespaces for XML::Stream to use when connecting. =head1 DESCRIPTION This module allows you to set and read elements from an XML::Stream Namespace. =head1 METHODS SetNamespace("mynamespace"); SetXMLNS("http://www.mynamespace.com/xmlns"); SetAttributes(attrib1=>"value1", attrib2=>"value2"); GetNamespace() returns "mynamespace" GetXMLNS() returns "http://www.mynamespace.com/xmlns" GetAttributes() returns a hash ( attrib1=>"value1",attrib2=>"value2") GetStream() returns the following string: "xmlns:mynamespace='http://www.nynamespace.com/xmlns' mynamespace:attrib1='value1' mynamespace:attrib2='value2'" =head1 EXAMPLES $myNamespace = new XML::Stream::Namespace("mynamspace"); $myNamespace->SetXMLNS("http://www.mynamespace.org/xmlns"); $myNamespace->SetAttributes(foo=>"bar", bob=>"vila"); $stream = new XML::Stream; $stream->Connect(name=>"foo.bar.org", port=>1234, namespace=>"foo:bar", namespaces=>[ $myNamespace ]); # # The above Connect will send the following as the opening string # of the stream to foo.bar.org:1234... # # # =head1 AUTHOR Written by Ryan Eatmon in February 2000 Idea By Thomas Charron in January of 2000 for http://etherx.jabber.org/streams/ Currently maintained by Darian Anthony Patrick. =head1 COPYRIGHT This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use Carp; use vars qw( $VERSION ); $VERSION = "1.23"; sub new { my $proto = shift; my $self = { }; ($self->{Namespace}) = @_ if ($#_ > -1); $self->{Attributes} = {}; bless($self,$proto); return $self; } sub SetNamespace { my $self = shift; my ($namespace) = @_; $self->{Namespace} = $namespace; } sub SetXMLNS { my $self = shift; my ($xmlns) = @_; $self->{XMLNS} = $xmlns; } sub SetAttributes { my $self = shift; my %att = @_; my $key; foreach $key (keys(%att)) { $self->{Attributes}->{$key} = $att{$key}; } } sub GetNamespace { my $self = shift; return $self->{Namespace}; } sub GetXMLNS { my $self = shift; return $self->{XMLNS}; } sub GetAttributes { my $self = shift; my ($attrib) = @_; return $self->{Attributes} if ($attrib eq ""); return $self->{Attributes}->{$attrib}; } sub GetStream { my $self = shift; my $string = ""; $string .= "xmlns:".$self->GetNamespace(); $string .= "='".$self->GetXMLNS()."'"; my $attrib; foreach $attrib (keys(%{$self->GetAttributes()})) { $string .= " ".$self->GetNamespace().":"; $string .= $attrib; $string .= "='".$self->GetAttributes($attrib)."'"; } return $string; } 1; XML-Stream-1.23/lib/XML/Stream/Node.pm0000644000175000017500000007173311321524510017707 0ustar dapatrickdapatrick############################################################################## # # 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. # # Jabber # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package XML::Stream::Node; =head1 NAME XML::Stream::Node - Functions to make building and parsing the tree easier to work with. =head1 SYNOPSIS Just a collection of functions that do not need to be in memory if you choose one of the other methods of data storage. This creates a hierarchy of Perl objects and provides various methods to manipulate the structure of the tree. It is much like the C library libxml. =head1 FORMAT The result of parsing: Hello thereHowdydo would be: [ tag: foo att: {} children: [ tag: head att: {id=>"a"} children: [ tag: "__xmlstream__:node:cdata" children: "Hello " ] [ tag: em children: [ tag: "__xmlstream__:node:cdata" children: "there" ] ] ] [ tag: bar children: [ tag: "__xmlstream__:node:cdata" children: "Howdy " ] [ tag: ref ] ] [ tag: "__xmlstream__:node:cdata" children: "do" ] ] =head1 METHODS new() - creates a new node. If you specify tag, then the root new(tag) tag is set. If you specify data, then cdata is added new(tag,cdata) to the node as well. Returns the created node. get_tag() - returns the root tag of the node. set_tag(tag) - set the root tag of the node to tag. add_child(node) - adds the specified node as a child to the current add_child(tag) node, or creates a new node with the specified tag add_child(tag,cdata) as the root node. Returns the node added. remove_child(node) - removes the child node from the current node. remove_cdata() - removes all of the cdata children from the current node. add_cdata(string) - adds the string as cdata onto the current nodes child list. get_cdata() - returns all of the cdata children concatenated together into one string. get_attrib(attrib) - returns the value of the attrib if it is valid, or returns undef is attrib is not a real attribute. put_attrib(hash) - for each key/value pair specified, create an attribute in the node. remove_attrib(attrib) - remove the specified attribute from the node. add_raw_xml(string,[string,...]) - directly add a string into the XML packet as the last child, with no translation. get_raw_xml() - return all of the XML in a single string, undef if there is no raw XML to include. remove_raw_xml() - remove all raw XML strings. children() - return all of the children of the node in a list. attrib() - returns a hash containing all of the attributes on this node. copy() - return a recursive copy of the node. XPath(path) - run XML::Stream::XPath on this node. XPathCheck(path) - run XML::Stream::XPath on this node and return 1 or 0 to see if it matches or not. GetXML() - return the node in XML string form. =head1 AUTHOR By Ryan Eatmon in June 2002 for http://jabber.org/ Currently maintained by Darian Anthony Patrick. =head1 COPYRIGHT This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use vars qw( $VERSION $LOADED ); $VERSION = "1.23"; $LOADED = 1; sub new { my $proto = shift; my $class = ref($proto) || $proto; if (ref($_[0]) eq "XML::Stream::Node") { return $_[0]; } my $self = {}; bless($self, $proto); my ($tag,$data) = @_; $self->set_tag($tag) if defined($tag); $self->add_cdata($data) if defined($data); $self->remove_raw_xml(); return $self; } sub debug { my $self = shift; my ($indent) = @_; $indent = "" unless defined($indent); if ($self->{TAG} eq "__xmlstream__:node:cdata") { print $indent,"cdata(",join("",@{$self->{CHILDREN}}),")\n"; } else { print $indent,"packet($self):\n"; print $indent,"tag: <$self->{TAG}\n"; if (scalar(keys(%{$self->{ATTRIBS}})) > 0) { print $indent,"attribs:\n"; foreach my $key (sort {$a cmp $b} keys(%{$self->{ATTRIBS}})) { print $indent," $key = '$self->{ATTRIBS}->{$key}'\n"; } } if ($#{$self->{CHILDREN}} == -1) { print $indent," />\n"; } else { print $indent," >\n"; print $indent,"children:\n"; foreach my $child (@{$self->{CHILDREN}}) { $child->debug($indent." "); } } print $indent," {TAG}>\n"; } } sub children { my $self = shift; return () unless exists($self->{CHILDREN}); return @{$self->{CHILDREN}}; } sub add_child { my $self = shift; my $child = new XML::Stream::Node(@_); push(@{$self->{CHILDREN}},$child); return $child; } sub remove_child { my $self = shift; my $child = shift; foreach my $index (0..$#{$self->{CHILDREN}}) { if ($child == $self->{CHILDREN}->[$index]) { splice(@{$self->{CHILDREN}},$index,1); last; } } } sub add_cdata { my $self = shift; my $child = new XML::Stream::Node("__xmlstream__:node:cdata"); foreach my $cdata (@_) { push(@{$child->{CHILDREN}},$cdata); } push(@{$self->{CHILDREN}},$child); return $child; } sub get_cdata { my $self = shift; my $cdata = ""; foreach my $child (@{$self->{CHILDREN}}) { $cdata .= join("",$child->children()) if ($child->get_tag() eq "__xmlstream__:node:cdata"); } return $cdata; } sub remove_cdata { my $self = shift; my @remove = (); foreach my $index (0..$#{$self->{CHILDREN}}) { if ($self->{CHILDREN}->[$index]->get_tag() eq "__xmlstream__:node:cdata") { unshift(@remove,$index); } } foreach my $index (@remove) { splice(@{$self->{CHILDREN}},$index,1); } } sub attrib { my $self = shift; return () unless exists($self->{ATTRIBS}); return %{$self->{ATTRIBS}}; } sub get_attrib { my $self = shift; my ($key) = @_; return unless exists($self->{ATTRIBS}->{$key}); return $self->{ATTRIBS}->{$key}; } sub put_attrib { my $self = shift; my (%att) = @_; foreach my $key (keys(%att)) { $self->{ATTRIBS}->{$key} = $att{$key}; } } sub remove_attrib { my $self = shift; my ($key) = @_; return unless exists($self->{ATTRIBS}->{$key}); delete($self->{ATTRIBS}->{$key}); } sub add_raw_xml { my $self = shift; my (@raw) = @_; push(@{$self->{RAWXML}},@raw); } sub get_raw_xml { my $self = shift; return if ($#{$self->{RAWXML}} == -1); return join("",@{$self->{RAWXML}}); } sub remove_raw_xml { my $self = shift; $self->{RAWXML} = []; } sub get_tag { my $self = shift; return $self->{TAG}; } sub set_tag { my $self = shift; my ($tag) = @_; $self->{TAG} = $tag; } sub XPath { my $self = shift; my @results = &XML::Stream::XPath($self,@_); return unless ($#results > -1); return $results[0] unless wantarray; return @results; } sub XPathCheck { my $self = shift; return &XML::Stream::XPathCheck($self,@_); } sub GetXML { my $self = shift; return &BuildXML($self,@_); } sub copy { my $self = shift; my $new_node = new XML::Stream::Node(); $new_node->set_tag($self->get_tag()); $new_node->put_attrib($self->attrib()); foreach my $child ($self->children()) { if ($child->get_tag() eq "__xmlstream__:node:cdata") { $new_node->add_cdata($child->children()); } else { $new_node->add_child($child->copy()); } } return $new_node; } ############################################################################## # # _handle_element - handles the main tag elements sent from the server. # On an open tag it creates a new XML::Parser::Node so # that _handle_cdata and _handle_element can add data # and tags to it later. # ############################################################################## sub _handle_element { my $self; $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); my ($sax, $tag, %att) = @_; my $sid = $sax->getSID(); $self->debug(2,"Node: _handle_element: sid($sid) sax($sax) tag($tag) att(",%att,")"); my $node = new XML::Stream::Node($tag); $node->put_attrib(%att); $self->debug(2,"Node: _handle_element: check(",$#{$self->{SIDS}->{$sid}->{node}},")"); if ($#{$self->{SIDS}->{$sid}->{node}} >= 0) { $self->{SIDS}->{$sid}->{node}->[$#{$self->{SIDS}->{$sid}->{node}}]-> add_child($node); } push(@{$self->{SIDS}->{$sid}->{node}},$node); } ############################################################################## # # _handle_cdata - handles the CDATA that is encountered. Also, in the # spirit of XML::Parser::Node it combines any sequential # CDATA into one tag. # ############################################################################## sub _handle_cdata { my $self; $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); my ($sax, $cdata) = @_; my $sid = $sax->getSID(); $self->debug(2,"Node: _handle_cdata: sid($sid) sax($sax) cdata($cdata)"); return if ($#{$self->{SIDS}->{$sid}->{node}} == -1); $self->debug(2,"Node: _handle_cdata: sax($sax) cdata($cdata)"); $self->{SIDS}->{$sid}->{node}->[$#{$self->{SIDS}->{$sid}->{node}}]-> add_cdata($cdata); } ############################################################################## # # _handle_close - when we see a close tag we need to pop the last element # from the list and push it onto the end of the previous # element. This is how we build our hierarchy. # ############################################################################## sub _handle_close { my $self; $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); my ($sax, $tag) = @_; my $sid = $sax->getSID(); $self->debug(2,"Node: _handle_close: sid($sid) sax($sax) tag($tag)"); $self->debug(2,"Node: _handle_close: check(",$#{$self->{SIDS}->{$sid}->{node}},")"); if ($#{$self->{SIDS}->{$sid}->{node}} == -1) { $self->debug(2,"Node: _handle_close: rootTag($self->{SIDS}->{$sid}->{rootTag}) tag($tag)"); if ($self->{SIDS}->{$sid}->{rootTag} ne $tag) { $self->{SIDS}->{$sid}->{streamerror} = "Root tag mis-match: <$self->{SIDS}->{$sid}->{rootTag}> ... \n"; } return; } my $CLOSED = pop @{$self->{SIDS}->{$sid}->{node}}; $self->debug(2,"Node: _handle_close: check2(",$#{$self->{SIDS}->{$sid}->{node}},")"); if($#{$self->{SIDS}->{$sid}->{node}} == -1) { push @{$self->{SIDS}->{$sid}->{node}}, $CLOSED; if (ref($self) ne "XML::Stream::Parser") { my $stream_prefix = $self->StreamPrefix($sid); if(defined($self->{SIDS}->{$sid}->{node}->[0]) && ($self->{SIDS}->{$sid}->{node}->[0]->get_tag() =~ /^${stream_prefix}\:/)) { my $node = $self->{SIDS}->{$sid}->{node}->[0]; $self->{SIDS}->{$sid}->{node} = []; $self->ProcessStreamPacket($sid,$node); } else { my $node = $self->{SIDS}->{$sid}->{node}->[0]; $self->{SIDS}->{$sid}->{node} = []; my @special = &XML::Stream::XPath( $node, '[@xmlns="'.&XML::Stream::ConstXMLNS("xmpp-sasl").'" or @xmlns="'.&XML::Stream::ConstXMLNS("xmpp-tls").'"]' ); if ($#special > -1) { my $xmlns = $node->get_attrib("xmlns"); $self->ProcessSASLPacket($sid,$node) if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-sasl")); $self->ProcessTLSPacket($sid,$node) if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-tls")); } else { &{$self->{CB}->{node}}($sid,$node); } } } } } ############################################################################## # # SetXMLData - takes a host of arguments and sets a portion of the specified # XML::Parser::Node object with that data. The function works # in two modes "single" or "multiple". "single" denotes that # the function should locate the current tag that matches this # data and overwrite it's contents with data passed in. # "multiple" denotes that a new tag should be created even if # others exist. # # type - single or multiple # XMLTree - pointer to XML::Stream Node object # tag - name of tag to create/modify (if blank assumes # working with top level tag) # data - CDATA to set for tag # attribs - attributes to ADD to tag # ############################################################################## sub SetXMLData { my ($type,$XMLTree,$tag,$data,$attribs) = @_; if ($tag ne "") { if ($type eq "single") { foreach my $child ($XMLTree->children()) { if ($$XMLTree[1]->[$child] eq $tag) { $XMLTree->remove_child($child); my $newChild = $XMLTree->add_child($tag); $newChild->put_attrib(%{$attribs}); $newChild->add_cdata($data) if ($data ne ""); return; } } } my $newChild = $XMLTree->add_child($tag); $newChild->put_attrib(%{$attribs}); $newChild->add_cdata($data) if ($data ne ""); } else { $XMLTree->put_attrib(%{$attribs}); $XMLTree->add_cdata($data) if ($data ne ""); } } ############################################################################## # # GetXMLData - takes a host of arguments and returns various data structures # that match them. # # type - "existence" - returns 1 or 0 if the tag exists in the # top level. # "value" - returns either the CDATA of the tag, or the # value of the attribute depending on which is # sought. This ignores any mark ups to the data # and just returns the raw CDATA. # "value array" - returns an array of strings representing # all of the CDATA in the specified tag. # This ignores any mark ups to the data # and just returns the raw CDATA. # "tree" - returns an XML::Parser::Node object with the # specified tag as the root tag. # "tree array" - returns an array of XML::Parser::Node # objects each with the specified tag as # the root tag. # "child array" - returns a list of all children nodes # not including CDATA nodes. # "attribs" - returns a hash with the attributes, and # their values, for the things that match # the parameters # "count" - returns the number of things that match # the arguments # "tag" - returns the root tag of this tree # XMLTree - pointer to XML::Parser::Node object # tag - tag to pull data from. If blank then the top level # tag is accessed. # attrib - attribute value to retrieve. Ignored for types # "value array", "tree", "tree array". If paired # with value can be used to filter tags based on # attributes and values. # value - only valid if an attribute is supplied. Used to # filter for tags that only contain this attribute. # Useful to search through multiple tags that all # reference different name spaces. # ############################################################################## sub GetXMLData { my ($type,$XMLTree,$tag,$attrib,$value) = @_; $tag = "" if !defined($tag); $attrib = "" if !defined($attrib); $value = "" if !defined($value); my $skipthis = 0; #------------------------------------------------------------------------- # Check if a child tag in the root tag is being requested. #------------------------------------------------------------------------- if ($tag ne "") { my $count = 0; my @array; foreach my $child ($XMLTree->children()) { if (($child->get_tag() eq $tag) || ($tag eq "*")) { #------------------------------------------------------------- # Filter out tags that do not contain the attribute and value. #------------------------------------------------------------- next if (($value ne "") && ($attrib ne "") && $child->get_attrib($attrib) && ($XMLTree->get_attrib($attrib) ne $value)); next if (($attrib ne "") && !$child->get_attrib($attrib)); #------------------------------------------------------------- # Check for existence #------------------------------------------------------------- if ($type eq "existence") { return 1; } #------------------------------------------------------------- # Return the raw CDATA value without mark ups, or the value of # the requested attribute. #------------------------------------------------------------- if ($type eq "value") { if ($attrib eq "") { my $str = $child->get_cdata(); return $str; } return $XMLTree->get_attrib($attrib) if defined($XMLTree->get_attrib($attrib)); } #------------------------------------------------------------- # Return an array of values that represent the raw CDATA without # mark up tags for the requested tags. #------------------------------------------------------------- if ($type eq "value array") { if ($attrib eq "") { my $str = $child->get_cdata(); push(@array,$str); } else { push(@array, $XMLTree->get_attrib($attrib)) if defined($XMLTree->get_attrib($attrib)); } } #------------------------------------------------------------- # Return a pointer to a new XML::Parser::Tree object that has # the requested tag as the root tag. #------------------------------------------------------------- if ($type eq "tree") { return $child; } #------------------------------------------------------------- # Return an array of pointers to XML::Parser::Tree objects # that have the requested tag as the root tags. #------------------------------------------------------------- if ($type eq "tree array") { push(@array,$child); } #------------------------------------------------------------- # Return an array of pointers to XML::Parser::Tree objects # that have the requested tag as the root tags. #------------------------------------------------------------- if ($type eq "child array") { push(@array,$child) if ($child->get_tag() ne "__xmlstream__:node:cdata"); } #------------------------------------------------------------- # Return a count of the number of tags that match #------------------------------------------------------------- if ($type eq "count") { $count++; } #------------------------------------------------------------- # Return the attribute hash that matches this tag #------------------------------------------------------------- if ($type eq "attribs") { return $XMLTree->attrib(); } } } #--------------------------------------------------------------------- # If we are returning arrays then return array. #--------------------------------------------------------------------- if (($type eq "tree array") || ($type eq "value array") || ($type eq "child array")) { return @array; } #--------------------------------------------------------------------- # If we are returning then count, then do so #--------------------------------------------------------------------- if ($type eq "count") { return $count; } } else { #--------------------------------------------------------------------- # This is the root tag, so handle things a level up. #--------------------------------------------------------------------- #--------------------------------------------------------------------- # Return the raw CDATA value without mark ups, or the value of the # requested attribute. #--------------------------------------------------------------------- if ($type eq "value") { if ($attrib eq "") { my $str = $XMLTree->get_cdata(); return $str; } return $XMLTree->get_attrib($attrib) if $XMLTree->get_attrib($attrib); } #--------------------------------------------------------------------- # Return a pointer to a new XML::Parser::Tree object that has the # requested tag as the root tag. #--------------------------------------------------------------------- if ($type eq "tree") { return $XMLTree; } #--------------------------------------------------------------------- # Return the 1 if the specified attribute exists in the root tag. #--------------------------------------------------------------------- if ($type eq "existence") { if ($attrib ne "") { return ($XMLTree->get_attrib($attrib) eq $value) if ($value ne ""); return defined($XMLTree->get_attrib($attrib)); } return 0; } #--------------------------------------------------------------------- # Return the attribute hash that matches this tag #--------------------------------------------------------------------- if ($type eq "attribs") { return $XMLTree->attrib(); } #--------------------------------------------------------------------- # Return the tag of this node #--------------------------------------------------------------------- if ($type eq "tag") { return $XMLTree->get_tag(); } } #------------------------------------------------------------------------- # Return 0 if this was a request for existence, or "" if a request for # a "value", or [] for "tree", "value array", and "tree array". #------------------------------------------------------------------------- return 0 if ($type eq "existence"); return "" if ($type eq "value"); return []; } ############################################################################## # # BuildXML - takes an XML::Parser::Tree object and builds the XML string # that it represents. # ############################################################################## sub BuildXML { my ($node,$rawXML) = @_; my $str = "<".$node->get_tag(); my %attrib = $node->attrib(); foreach my $att (sort {$a cmp $b} keys(%attrib)) { $str .= " ".$att."='".&XML::Stream::EscapeXML($attrib{$att})."'"; } my @children = $node->children(); if (($#children > -1) || (defined($rawXML) && ($rawXML ne "")) || (defined($node->get_raw_xml()) && ($node->get_raw_xml() ne "")) ) { $str .= ">"; foreach my $child (@children) { if ($child->get_tag() eq "__xmlstream__:node:cdata") { $str .= &XML::Stream::EscapeXML(join("",$child->children())); } else { $str .= &XML::Stream::Node::BuildXML($child); } } $str .= $node->get_raw_xml() if (defined($node->get_raw_xml()) && ($node->get_raw_xml() ne "") ); $str .= $rawXML if (defined($rawXML) && ($rawXML ne "")); $str .= "get_tag().">"; } else { $str .= "/>"; } return $str; } ############################################################################## # # XML2Config - takes an XML data tree and turns it into a hash of hashes. # This only works for certain kinds of XML trees like this: # # # 1 # # foo # # 5 # # # The resulting hash would be: # # $hash{bar} = 1; # $hash{x}->{y} = "foo"; # $hash{z} = 5; # # Good for config files. # ############################################################################## sub XML2Config { my ($XMLTree) = @_; my %hash; foreach my $tree (&XML::Stream::GetXMLData("tree array",$XMLTree,"*")) { if ($tree->get_tag() eq "__xmlstream__:node:cdata") { my $str = join("",$tree->children()); return $str unless ($str =~ /^\s*$/); } else { if (&XML::Stream::GetXMLData("count",$XMLTree,$tree->get_tag()) > 1) { push(@{$hash{$tree->get_tag()}},&XML::Stream::XML2Config($tree)); } else { $hash{$tree->get_tag()} = &XML::Stream::XML2Config($tree); } } } return \%hash; } 1; XML-Stream-1.23/lib/XML/Stream/XPath.pm0000644000175000017500000000255211321523765020052 0ustar dapatrickdapatrick############################################################################## # # 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. # # Jabber # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package XML::Stream::XPath; use 5.008; use strict; use vars qw( $VERSION %FUNCTIONS ); $VERSION = "1.23"; use XML::Stream::XPath::Value; use XML::Stream::XPath::Op; use XML::Stream::XPath::Query; sub AddFunction { my $function = shift; my $code = shift; if (!defined($code)) { delete($FUNCTIONS{$code}); return; } $FUNCTIONS{$function} = $code; } 1; XML-Stream-1.23/lib/XML/Stream/Parser.pm0000644000175000017500000003440211321524577020263 0ustar dapatrickdapatrick############################################################################## # # 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. # # Jabber # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package XML::Stream::Parser; =head1 NAME XML::Stream::Parser - SAX XML Parser for XML Streams =head1 SYNOPSIS Light weight XML parser that builds XML::Parser::Tree objects from the incoming stream and passes them to a function to tell whoever is using it that there are new packets. =head1 DESCRIPTION This module provides a very light weight parser =head1 METHODS =head1 EXAMPLES =head1 AUTHOR By Ryan Eatmon in January of 2001 for http://jabber.org/ Currently maintained by Darian Anthony Patrick. =head1 COPYRIGHT This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use vars qw( $VERSION ); $VERSION = "1.23"; use XML::Stream::Tree; use XML::Stream::Node; sub new { my $self = { }; bless($self); my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $self->{PARSING} = 0; $self->{DOC} = 0; $self->{XML} = ""; $self->{CNAME} = (); $self->{CURR} = 0; $args{nonblocking} = 0 unless exists($args{nonblocking}); $self->{NONBLOCKING} = delete($args{nonblocking}); $self->{DEBUGTIME} = 0; $self->{DEBUGTIME} = $args{debugtime} if exists($args{debugtime}); $self->{DEBUGLEVEL} = 0; $self->{DEBUGLEVEL} = $args{debuglevel} if exists($args{debuglevel}); $self->{DEBUGFILE} = ""; if (exists($args{debugfh}) && ($args{debugfh} ne "")) { $self->{DEBUGFILE} = $args{debugfh}; $self->{DEBUG} = 1; } if ((exists($args{debugfh}) && ($args{debugfh} eq "")) || (exists($args{debug}) && ($args{debug} ne ""))) { $self->{DEBUG} = 1; if (lc($args{debug}) eq "stdout") { $self->{DEBUGFILE} = new FileHandle(">&STDERR"); $self->{DEBUGFILE}->autoflush(1); } else { if (-e $args{debug}) { if (-w $args{debug}) { $self->{DEBUGFILE} = new FileHandle(">$args{debug}"); $self->{DEBUGFILE}->autoflush(1); } else { print "WARNING: debug file ($args{debug}) is not writable by you\n"; print " No debug information being saved.\n"; $self->{DEBUG} = 0; } } else { $self->{DEBUGFILE} = new FileHandle(">$args{debug}"); if (defined($self->{DEBUGFILE})) { $self->{DEBUGFILE}->autoflush(1); } else { print "WARNING: debug file ($args{debug}) does not exist \n"; print " and is not writable by you.\n"; print " No debug information being saved.\n"; $self->{DEBUG} = 0; } } } } $self->{SID} = exists($args{sid}) ? $args{sid} : "__xmlstream__:sid"; $self->{STYLE} = (exists($args{style}) ? lc($args{style}) : "tree"); $self->{DTD} = (exists($args{dtd}) ? lc($args{dtd}) : 0); if ($self->{STYLE} eq "tree") { $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); }; $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); }; $self->{HANDLER}->{startElement} = sub{ &XML::Stream::Tree::_handle_element(@_); }; $self->{HANDLER}->{endElement} = sub{ &XML::Stream::Tree::_handle_close(@_); }; $self->{HANDLER}->{characters} = sub{ &XML::Stream::Tree::_handle_cdata(@_); }; } elsif ($self->{STYLE} eq "node") { $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); }; $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); }; $self->{HANDLER}->{startElement} = sub{ &XML::Stream::Node::_handle_element(@_); }; $self->{HANDLER}->{endElement} = sub{ &XML::Stream::Node::_handle_close(@_); }; $self->{HANDLER}->{characters} = sub{ &XML::Stream::Node::_handle_cdata(@_); }; } $self->setHandlers(%{$args{handlers}}); $self->{XMLONHOLD} = ""; return $self; } ########################################################################### # # debug - prints the arguments to the debug log if debug is turned on. # ########################################################################### sub debug { return if ($_[1] > $_[0]->{DEBUGLEVEL}); my $self = shift; my ($limit,@args) = @_; return if ($self->{DEBUGFILE} eq ""); my $fh = $self->{DEBUGFILE}; if ($self->{DEBUGTIME} == 1) { my ($sec,$min,$hour) = localtime(time); print $fh sprintf("[%02d:%02d:%02d] ",$hour,$min,$sec); } print $fh "XML::Stream::Parser: $self->{STYLE}: @args\n"; } sub setSID { my $self = shift; my $sid = shift; $self->{SID} = $sid; } sub getSID { my $self = shift; return $self->{SID}; } sub setHandlers { my $self = shift; my (%handlers) = @_; foreach my $handler (keys(%handlers)) { $self->{HANDLER}->{$handler} = $handlers{$handler}; } } sub parse { my $self = shift; my $xml = shift; return unless defined($xml); return if ($xml eq ""); if ($self->{XMLONHOLD} ne "") { $self->{XML} = $self->{XMLONHOLD}; $self->{XMLONHOLD} = ""; } # XXX change this to not use regex? while($xml =~ s/<\!--.*?-->//gs) {} $self->{XML} .= $xml; return if ($self->{PARSING} == 1); $self->{PARSING} = 1; if(!$self->{DOC} == 1) { my $start = index($self->{XML},"<"); if ((substr($self->{XML},$start,3) eq "{XML},$start,3) eq "{XML},"?>"); if ($close == -1) { $self->{PARSING} = 0; return; } $self->{XML} = substr($self->{XML},$close+2,length($self->{XML})-$close-2); } &{$self->{HANDLER}->{startDocument}}($self); $self->{DOC} = 1; } while(1) { if (length($self->{XML}) == 0) { $self->{PARSING} = 0; return $self->returnData(0); } my $eclose = -1; $eclose = index($self->{XML},"{CNAME}->[$self->{CURR}].">") if ($#{$self->{CNAME}} > -1); if ($eclose == 0) { $self->{XML} = substr($self->{XML},length($self->{CNAME}->[$self->{CURR}])+3,length($self->{XML})-length($self->{CNAME}->[$self->{CURR}])-3); $self->{PARSING} = 0 if ($self->{NONBLOCKING} == 1); &{$self->{HANDLER}->{endElement}}($self,$self->{CNAME}->[$self->{CURR}]); $self->{PARSING} = 1 if ($self->{NONBLOCKING} == 1); $self->{CURR}--; if ($self->{CURR} == 0) { $self->{DOC} = 0; $self->{PARSING} = 0; &{$self->{HANDLER}->{endDocument}}($self); return $self->returnData(0); } next; } my $estart = index($self->{XML},"<"); my $cdatastart = index($self->{XML},"{XML},">"); if ($close == -1) { $self->{PARSING} = 0; return $self->returnData(0); } my $empty = (substr($self->{XML},$close-1,1) eq "/"); my $starttag = substr($self->{XML},1,$close-($empty ? 2 : 1)); my $nextspace = index($starttag," "); my $attribs; my $name; if ($nextspace != -1) { $name = substr($starttag,0,$nextspace); $attribs = substr($starttag,$nextspace+1,length($starttag)-$nextspace-1); } else { $name = $starttag; } my %attribs = $self->attribution($attribs); if (($self->{DTD} == 1) && (exists($attribs{xmlns}))) { } &{$self->{HANDLER}->{startElement}}($self,$name,%attribs); if($empty == 1) { &{$self->{HANDLER}->{endElement}}($self,$name); } else { $self->{CURR}++; $self->{CNAME}->[$self->{CURR}] = $name; } $self->{XML} = substr($self->{XML},$close+1,length($self->{XML})-$close-1); next; } if ($cdatastart == 0) { my $cdataclose = index($self->{XML},"]]>"); if ($cdataclose == -1) { $self->{PARSING} = 0; return $self->returnData(0); } &{$self->{HANDLER}->{characters}}($self,substr($self->{XML},9,$cdataclose-9)); $self->{XML} = substr($self->{XML},$cdataclose+3,length($self->{XML})-$cdataclose-3); next; } if ($estart == -1) { $self->{XMLONHOLD} = $self->{XML}; $self->{XML} = ""; } elsif (($cdatastart == -1) || ($cdatastart > $estart)) { &{$self->{HANDLER}->{characters}}($self,$self->entityCheck(substr($self->{XML},0,$estart))); $self->{XML} = substr($self->{XML},$estart,length($self->{XML})-$estart); } } } sub attribution { my $self = shift; my $str = shift; $str = "" unless defined($str); my %attribs; while(1) { my $eq = index($str,"="); if((length($str) == 0) || ($eq == -1)) { return %attribs; } my $ids; my $id; my $id1 = index($str,"\'"); my $id2 = index($str,"\""); if((($id1 < $id2) && ($id1 != -1)) || ($id2 == -1)) { $ids = $id1; $id = "\'"; } else { if((($id2 < $id1) && ($id1 == -1)) || ($id2 != -1)) { $ids = $id2; $id = "\""; } } my $nextid = index($str,$id,$ids+1); my $val = substr($str,$ids+1,$nextid-$ids-1); my $key = substr($str,0,$eq); while($key =~ s/\s//) {} $attribs{$key} = $self->entityCheck($val); $str = substr($str,$nextid+1,length($str)-$nextid-1); } return %attribs; } sub entityCheck { my $self = shift; my $str = shift; while($str =~ s/\<\;/\/) {} while($str =~ s/\"\;/\"/) {} while($str =~ s/\&apos\;/\'/) {} while($str =~ s/\&\;/\&/) {} return $str; } sub parsefile { my $self = shift; my $fileName = shift; open(FILE,"<",$fileName); my $file; while() { $file .= $_; } $self->parse($file); close(FILE); return $self->returnData(); } sub returnData { my $self = shift; my $clearData = shift; $clearData = 1 unless defined($clearData); my $sid = $self->{SID}; if ($self->{STYLE} eq "tree") { return unless exists($self->{SIDS}->{$sid}->{tree}); my @tree = @{$self->{SIDS}->{$sid}->{tree}}; delete($self->{SIDS}->{$sid}->{tree}) if ($clearData == 1); return ( \@tree ); } if ($self->{STYLE} eq "node") { return unless exists($self->{SIDS}->{$sid}->{node}); my $node = $self->{SIDS}->{$sid}->{node}->[0]; delete($self->{SIDS}->{$sid}->{node}) if ($clearData == 1); return $node; } } sub startDocument { my $self = shift; } sub endDocument { my $self = shift; } sub startElement { my $self = shift; my ($sax, $tag, %att) = @_; return unless ($self->{DOC} == 1); if ($self->{STYLE} eq "debug") { print "$self->{DEBUGHEADER} \\\\ (",join(" ",%att),")\n"; $self->{DEBUGHEADER} .= $tag." "; } else { my @NEW; if($#{$self->{TREE}} < 0) { push @{$self->{TREE}}, $tag; } else { push @{ $self->{TREE}[ $#{$self->{TREE}}]}, $tag; } push @NEW, \%att; push @{$self->{TREE}}, \@NEW; } } sub characters { my $self = shift; my ($sax, $cdata) = @_; return unless ($self->{DOC} == 1); if ($self->{STYLE} eq "debug") { my $str = $cdata; $str =~ s/\n/\#10\;/g; print "$self->{DEBUGHEADER} || $str\n"; } else { return if ($#{$self->{TREE}} == -1); my $pos = $#{$self->{TREE}}; if ($pos > 0 && $self->{TREE}[$pos - 1] eq "0") { $self->{TREE}[$pos - 1] .= $cdata; } else { push @{$self->{TREE}[$#{$self->{TREE}}]}, 0; push @{$self->{TREE}[$#{$self->{TREE}}]}, $cdata; } } } sub endElement { my $self = shift; my ($sax, $tag) = @_; return unless ($self->{DOC} == 1); if ($self->{STYLE} eq "debug") { $self->{DEBUGHEADER} =~ s/\S+\ $//; print "$self->{DEBUGHEADER} //\n"; } else { my $CLOSED = pop @{$self->{TREE}}; if($#{$self->{TREE}} < 1) { push @{$self->{TREE}}, $CLOSED; if($self->{TREE}->[0] eq "stream:error") { $self->{STREAMERROR} = $self->{TREE}[1]->[2]; } } else { push @{$self->{TREE}[$#{$self->{TREE}}]}, $CLOSED; } } } 1; XML-Stream-1.23/lib/XML/Stream/Parser/0000755000175000017500000000000011321531273017711 5ustar dapatrickdapatrickXML-Stream-1.23/lib/XML/Stream/Parser/DTD.pm0000644000175000017500000004263511321524620020672 0ustar dapatrickdapatrick############################################################################## # # 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. # # Jabber # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package XML::Stream::Parser::DTD; =head1 NAME XML::Stream::Parser::DTD - XML DTD Parser and Verifier =head1 SYNOPSIS This is a work in progress. I had need for a DTD parser and verifier and so am working on it here. If you are reading this then you are snooping. =) =head1 DESCRIPTION This module provides the initial code for a DTD parser and verifier. =head1 METHODS =head1 EXAMPLES =head1 AUTHOR By Ryan Eatmon in February of 2001 for http://jabber.org/ Currently maintained by Darian Anthony Patrick. =head1 COPYRIGHT This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use vars qw( $VERSION ); $VERSION = "1.23"; sub new { my $self = { }; bless($self); my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $self->{URI} = $args{uri}; $self->{PARSING} = 0; $self->{DOC} = 0; $self->{XML} = ""; $self->{CNAME} = (); $self->{CURR} = 0; $self->{ENTITY}->{"<"} = "<"; $self->{ENTITY}->{">"} = ">"; $self->{ENTITY}->{"""} = "\""; $self->{ENTITY}->{"'"} = "'"; $self->{ENTITY}->{"&"} = "&"; $self->{HANDLER}->{startDocument} = sub{ $self->startDocument(@_); }; $self->{HANDLER}->{endDocument} = sub{ $self->endDocument(@_); }; $self->{HANDLER}->{startElement} = sub{ $self->startElement(@_); }; $self->{HANDLER}->{endElement} = sub{ $self->endElement(@_); }; $self->{STYLE} = "debug"; open(DTD,$args{uri}); my $dtd = join("",); close(DTD); $self->parse($dtd); return $self; } sub parse { my $self = shift; my $xml = shift; while($xml =~ s/<\!--.*?-->//gs) {} while($xml =~ s/\n//g) {} $self->{XML} .= $xml; return if ($self->{PARSING} == 1); $self->{PARSING} = 1; if(!$self->{DOC} == 1) { my $start = index($self->{XML},"<"); if (substr($self->{XML},$start,3) =~ /^<\?x$/i) { my $close = index($self->{XML},"?>"); if ($close == -1) { $self->{PARSING} = 0; return; } $self->{XML} = substr($self->{XML},$close+2,length($self->{XML})-$close-2); } &{$self->{HANDLER}->{startDocument}}($self); $self->{DOC} = 1; } while(1) { if (length($self->{XML}) == 0) { $self->{PARSING} = 0; return; } my $estart = index($self->{XML},"<"); if ($estart == -1) { $self->{PARSING} = 0; return; } my $close = index($self->{XML},">"); my $dtddata = substr($self->{XML},$estart+1,$close-1); my $nextspace = index($dtddata," "); my $attribs; my $type = substr($dtddata,0,$nextspace); $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1); $nextspace = index($dtddata," "); if ($type eq "!ENTITY") { $self->entity($type,$dtddata); } else { my $tag = substr($dtddata,0,$nextspace); $dtddata = substr($dtddata,$nextspace+1,length($dtddata)-$nextspace-1); $nextspace = index($dtddata," "); $self->element($type,$tag,$dtddata) if ($type eq "!ELEMENT"); $self->attlist($type,$tag,$dtddata) if ($type eq "!ATTLIST"); } $self->{XML} = substr($self->{XML},$close+1,length($self->{XML})-$close-1); next; } } sub startDocument { my $self = shift; } sub endDocument { my $self = shift; } sub entity { my $self = shift; my ($type, $data) = @_; foreach my $entity (keys(%{$self->{ENTITY}})) { $data =~ s/$entity/$self->{ENTITY}->{$entity}/g; } my ($symbol,$tag,undef,$string) = ($data =~ /^\s*(\S+)\s+(\S+)\s+(\"|\')([^\3]*)\3\s*$/); $self->{ENTITY}->{"${symbol}${tag}\;"} = $string; } sub element { my $self = shift; my ($type, $tag, $data) = @_; foreach my $entity (keys(%{$self->{ENTITY}})) { $data =~ s/$entity/$self->{ENTITY}->{$entity}/g; } $self->{COUNTER}->{$tag} = 0 unless exists($self->{COUNTER}->{$tag}); $self->parsegrouping($tag,\$self->{ELEMENT}->{$tag},$data); $self->flattendata(\$self->{ELEMENT}->{$tag}); } sub flattendata { my $self = shift; my $dstr = shift; if ($$dstr->{type} eq "list") { foreach my $index (0..$#{$$dstr->{list}}) { $self->flattendata(\$$dstr->{list}->[$index]); } if (!exists($$dstr->{repeat}) && ($#{$$dstr->{list}} == 0)) { $$dstr = $$dstr->{list}->[0]; } } } sub parsegrouping { my $self = shift; my ($tag,$dstr,$data) = @_; $data =~ s/^\s*//; $data =~ s/\s*$//; if ($data =~ /[\*\+\?]$/) { ($$dstr->{repeat}) = ($data =~ /(.)$/); $data =~ s/.$//; } if ($data =~ /^\(.*\)$/) { my ($seperator) = ($data =~ /^\(\s*\S+\s*(\,|\|)/); $$dstr->{ordered} = "yes" if ($seperator eq ","); $$dstr->{ordered} = "no" if ($seperator eq "|"); my $count = 0; $$dstr->{type} = "list"; foreach my $grouping ($self->groupinglist($data,$seperator)) { $self->parsegrouping($tag,\$$dstr->{list}->[$count],$grouping); $count++; } } else { $$dstr->{type} = "element"; $$dstr->{element} = $data; $self->{COUNTER}->{$data} = 0 unless exists($self->{COUNTER}->{$data}); $self->{COUNTER}->{$data}++; $self->{CHILDREN}->{$tag}->{$data} = 1; } } sub attlist { my $self = shift; my ($type, $tag, $data) = @_; foreach my $entity (keys(%{$self->{ENTITY}})) { $data =~ s/$entity/$self->{ENTITY}->{$entity}/g; } while($data ne "") { my ($att) = ($data =~ /^\s*(\S+)/); $data =~ s/^\s*\S+\s*//; my $value; if ($data =~ /^\(/) { $value = $self->getgrouping($data); $data = substr($data,length($value)+1,length($data)); $data =~ s/^\s*//; $self->{ATTLIST}->{$tag}->{$att}->{type} = "list"; foreach my $val (split(/\s*\|\s*/,substr($value,1,length($value)-2))) { $self->{ATTLIST}->{$tag}->{$att}->{value}->{$val} = 1; } } else { ($value) = ($data =~ /^(\S+)/); $data =~ s/^\S+\s*//; $self->{ATTLIST}->{$tag}->{$att}->{type} = $value; } my $default; if ($data =~ /^\"|^\'/) { my($sq,$val) = ($data =~ /^(\"|\')([^\"\']*)\1/); $default = $val; $data =~ s/^$sq$val$sq\s*//; } else { ($default) = ($data =~ /^(\S+)/); $data =~ s/^\S+\s*//; } $self->{ATTLIST}->{$tag}->{$att}->{default} = $default; } } sub getgrouping { my $self = shift; my ($data) = @_; my $count = 0; my $parens = 0; foreach my $char (split("",$data)) { $parens++ if ($char eq "("); $parens-- if ($char eq ")"); $count++; last if ($parens == 0); } return substr($data,0,$count); } sub groupinglist { my $self = shift; my ($grouping,$seperator) = @_; my @list; my $item = ""; my $parens = 0; my $word = ""; $grouping = substr($grouping,1,length($grouping)-2) if ($grouping =~ /^\(/); foreach my $char (split("",$grouping)) { $parens++ if ($char eq "("); $parens-- if ($char eq ")"); if (($parens == 0) && ($char eq $seperator)) { push(@list,$word); $word = ""; } else { $word .= $char; } } push(@list,$word) unless ($word eq ""); return @list; } sub root { my $self = shift; my $tag = shift; my @root; foreach my $tag (keys(%{$self->{COUNTER}})) { push(@root,$tag) if ($self->{COUNTER}->{$tag} == 0); } print "ERROR: Too many root tags... Check the DTD...\n" if ($#root > 0); return $root[0]; } sub children { my $self = shift; my ($tag,$tree) = @_; return unless exists ($self->{CHILDREN}->{$tag}); return if (exists($self->{CHILDREN}->{$tag}->{EMPTY})); if (defined($tree)) { my @current; foreach my $current (&XML::Stream::GetXMLData("tree array",$tree,"*","","")) { push(@current,$$current[0]); } return $self->allowedchildren($self->{ELEMENT}->{$tag},\@current); } return $self->allowedchildren($self->{ELEMENT}->{$tag}); } sub allowedchildren { my $self = shift; my ($dstr,$current) = @_; my @allowed; if ($dstr->{type} eq "element") { my $test = (defined($current) && $#{@{$current}} > -1) ? $$current[0] : ""; shift(@{$current}) if ($dstr->{element} eq $test); if ($self->repeatcheck($dstr,$test) == 1) { return $dstr->{element}; } } else { foreach my $index (0..$#{$dstr->{list}}) { push(@allowed,$self->allowedchildren($dstr->{list}->[$index],$current)); } } return @allowed; } sub repeatcheck { my $self = shift; my ($dstr,$tag) = @_; $dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr}); # print "repeatcheck: tag($tag)\n"; # print "repeatcheck: repeat($dstr->{repeat})\n" # if exists($dstr->{repeat}); my $return = 0; $return = ((!defined($tag) || ($tag eq $dstr->{element})) ? 0 : 1) if (!exists($dstr->{repeat}) || ($dstr->{repeat} eq "?")); $return = ((defined($tag) || (exists($dstr->{ordered}) && ($dstr->{ordered} eq "yes"))) ? 1 : 0) if (exists($dstr->{repeat}) && (($dstr->{repeat} eq "+") || ($dstr->{repeat} eq "*"))); # print "repeatcheck: return($return)\n"; return $return; } sub required { my $self = shift; my ($dstr,$tag,$count) = @_; $dstr = $self->{ELEMENT}->{$dstr} if exists($self->{ELEMENT}->{$dstr}); if ($dstr->{type} eq "element") { return 0 if ($dstr->{element} ne $tag); return 1 if !exists($dstr->{repeat}); return 1 if (($dstr->{repeat} eq "+") && ($count == 1)) ; } else { return 0 if (($dstr->{repeat} eq "*") || ($dstr->{repeat} eq "?")); my $test = 0; foreach my $index (0..$#{$dstr->{list}}) { $test = $test | $self->required($dstr->{list}->[$index],$tag,$count); } return $test; } return 0; } sub addchild { my $self = shift; my ($tag,$child,$tree) = @_; # print "addchild: tag($tag) child($child)\n"; my @current; if (defined($tree)) { # &Net::Jabber::printData("\$tree",$tree); @current = &XML::Stream::GetXMLData("index array",$tree,"*","",""); # &Net::Jabber::printData("\$current",\@current); } my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current); return $tree unless ("@newBranch" ne ""); # &Net::Jabber::printData("\$newBranch",\@newBranch); my $location = shift(@newBranch); if ($location eq "end") { splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch); } else { splice(@{$$tree[1]},$location,0,@newBranch); } return $tree; } sub addcdata { my $self = shift; my ($tag,$child,$tree) = @_; # print "addchild: tag($tag) child($child)\n"; my @current; if (defined($tree)) { # &Net::Jabber::printData("\$tree",$tree); @current = &XML::Stream::GetXMLData("index array",$tree,"*","",""); # &Net::Jabber::printData("\$current",\@current); } my @newBranch = $self->addchildrecurse($self->{ELEMENT}->{$tag},$child,\@current); return $tree unless ("@newBranch" ne ""); # &Net::Jabber::printData("\$newBranch",\@newBranch); my $location = shift(@newBranch); if ($location eq "end") { splice(@{$$tree[1]},@{$$tree[1]},0,@newBranch); } else { splice(@{$$tree[1]},$location,0,@newBranch); } return $tree; } sub addchildrecurse { my $self = shift; my ($dstr,$child,$current) = @_; # print "addchildrecurse: child($child) type($dstr->{type})\n"; if ($dstr->{type} eq "element") { # print "addchildrecurse: tag($dstr->{element})\n"; my $count = 0; while(($#{@{$current}} > -1) && ($dstr->{element} eq $$current[0])) { shift(@{$current}); shift(@{$current}); $count++; } if (($dstr->{element} eq $child) && ($self->repeatcheck($dstr,(($count > 0) ? $child : "")) == 1)) { my @return = ( "end" , $self->newbranch($child)); @return = ($$current[1], $self->newbranch($child)) if ($#{@{$current}} > -1); # print "addchildrecurse: Found the spot! (",join(",",@return),")\n"; return @return; } } else { foreach my $index (0..$#{$dstr->{list}}) { my @newBranch = $self->addchildrecurse($dstr->{list}->[$index],$child,$current); return @newBranch if ("@newBranch" ne ""); } } # print "Let's blow....\n"; return; } sub deletechild { my $self = shift; my ($tag,$parent,$parenttree,$tree) = @_; return $tree unless exists($self->{ELEMENT}->{$tag}); return $tree if $self->required($parent,$tag,&XML::Stream::GetXMLData("count",$parenttree,$tag)); return []; } sub newbranch { my $self = shift; my $tag = shift; $tag = $self->root() unless defined($tag); my @tree = (); return ("0","") if ($tag eq "#PCDATA"); push(@tree,$tag); push(@tree,[ {} ]); foreach my $att ($self->attribs($tag)) { $tree[1]->[0]->{$att} = "" if (($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED") && ($self->{ATTLIST}->{$tag}->{$att}->{type} eq "CDATA")); } push(@{$tree[1]},$self->recursebranch($self->{ELEMENT}->{$tag})); return @tree; } sub recursebranch { my $self = shift; my $dstr = shift; my @tree; if (($dstr->{type} eq "element") && ($dstr->{element} ne "EMPTY")) { @tree = $self->newbranch($dstr->{element}) if (!exists($dstr->{repeat}) || ($dstr->{repeat} eq "+")); } else { foreach my $index (0..$#{$dstr->{list}}) { push(@tree,$self->recursebranch($dstr->{list}->[$index])) if (!exists($dstr->{repeat}) || ($dstr->{repeat} eq "+")); } } return @tree; } sub attribs { my $self = shift; my ($tag,$tree) = @_; return unless exists ($self->{ATTLIST}->{$tag}); if (defined($tree)) { my %current = &XML::Stream::GetXMLData("attribs",$tree,"","",""); return $self->allowedattribs($tag,\%current); } return $self->allowedattribs($tag); } sub allowedattribs { my $self = shift; my ($tag,$current) = @_; my %allowed; foreach my $att (keys(%{$self->{ATTLIST}->{$tag}})) { $allowed{$att} = 1 unless (defined($current) && exists($current->{$att})); } return sort {$a cmp $b} keys(%allowed); } sub attribvalue { my $self = shift; my $tag = shift; my $att = shift; return $self->{ATTLIST}->{$tag}->{$att}->{type} if ($self->{ATTLIST}->{$tag}->{$att}->{type} ne "list"); return sort {$a cmp $b} keys(%{$self->{ATTLIST}->{$tag}->{$att}->{value}}); } sub addattrib { my $self = shift; my ($tag,$att,$tree) = @_; return $tree unless exists($self->{ATTLIST}->{$tag}); return $tree unless exists($self->{ATTLIST}->{$tag}->{$att}); my $default = $self->{ATTLIST}->{$tag}->{$att}->{default}; $default = "" if ($default eq "#REQUIRED"); $default = "" if ($default eq "#IMPLIED"); $$tree[1]->[0]->{$att} = $default; return $tree; } sub attribrequired { my $self = shift; my ($tag,$att) = @_; return 0 unless exists($self->{ATTLIST}->{$tag}); return 0 unless exists($self->{ATTLIST}->{$tag}->{$att}); return 1 if ($self->{ATTLIST}->{$tag}->{$att}->{default} eq "#REQUIRED"); return 0; } sub deleteattrib { my $self = shift; my ($tag,$att,$tree) = @_; return $tree unless exists($self->{ATTLIST}->{$tag}); return $tree unless exists($self->{ATTLIST}->{$tag}->{$att}); return if $self->attribrequired($tag,$att); delete($$tree[1]->[0]->{$att}); return $tree; } XML-Stream-1.23/lib/XML/Stream/XPath/0000755000175000017500000000000011321531273017501 5ustar dapatrickdapatrickXML-Stream-1.23/lib/XML/Stream/XPath/Value.pm0000644000175000017500000000550511321523765021127 0ustar dapatrickdapatrick############################################################################## # # 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. # # Jabber # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package XML::Stream::XPath::Value; use 5.008; use strict; use vars qw( $VERSION ); $VERSION = "1.23"; sub new { my $proto = shift; my $self = { }; bless($self,$proto); $self->setList(@_); $self->setValues(); $self->setAttribs(); $self->setValid(0); $self->in_context(0); return $self; } sub setList { my $self = shift; my (@values) = @_; $self->{LIST} = \@values; } sub getList { my $self = shift; return unless ($#{$self->{LIST}} > -1); return @{$self->{LIST}}; } sub getFirstElem { my $self = shift; return unless ($#{$self->{LIST}} > -1); return $self->{LIST}->[0]; } sub setValues { my $self = shift; my (@values) = @_; $self->{VALUES} = \@values; } sub getValues { my $self = shift; return unless ($#{$self->{VALUES}} > -1); return $self->{VALUES}->[0] if !wantarray; return @{$self->{VALUES}}; } sub setAttribs { my $self = shift; my (%attribs) = @_; $self->{ATTRIBS} = \%attribs; } sub getAttribs { my $self = shift; return unless (scalar(keys(%{$self->{ATTRIBS}})) > 0); return %{$self->{ATTRIBS}}; } sub setValid { my $self = shift; my $valid = shift; $self->{VALID} = $valid; } sub check { my $self = shift; return $self->{VALID}; } sub in_context { my $self = shift; my $in_context = shift; if (defined($in_context)) { $self->{INCONTEXT} = $in_context; } return $self->{INCONTEXT}; } sub display { my $self = shift; if (0) { print "VALUE: list(",join(",",@{$self->{LIST}}),")\n"; } else { print "VALUE: list(\n"; foreach my $elem (@{$self->{LIST}}) { print "VALUE: ",$elem->GetXML(),"\n"; } print "VALUE: )\n"; } print "VALUE: values(",join(",",@{$self->{VALUES}}),")\n"; } 1; XML-Stream-1.23/lib/XML/Stream/XPath/Op.pm0000644000175000017500000004206011321523765020426 0ustar dapatrickdapatrick############################################################################## # # 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. # # Jabber # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## ############################################################################## # # Op - Base Op class # ############################################################################## package XML::Stream::XPath::Op; use 5.008; use strict; use vars qw( $VERSION ); $VERSION = "1.23"; sub new { my $proto = shift; return &allocate($proto,@_); } sub allocate { my $proto = shift; my $self = { }; bless($self,$proto); $self->{TYPE} = shift; $self->{VALUE} = shift; return $self; } sub getValue { my $self = shift; return $self->{VALUE}; } sub calcStr { my $self = shift; return $self->{VALUE}; } sub getType { my $self = shift; return $self->{TYPE}; } sub isValid { my $self = shift; my $ctxt = shift; return 1; } sub display { my $self = shift; my $space = shift; $space = "" unless defined($space); print $space,"OP: type($self->{TYPE}) value($self->{VALUE})\n"; } ############################################################################## # # PositionOp - class to handle [0] ops # ############################################################################## package XML::Stream::XPath::PositionOp; use vars qw (@ISA); @ISA = ( "XML::Stream::XPath::Op" ); sub new { my $proto = shift; my $self = $proto->allocate("POSITION",""); $self->{POS} = shift; return $self; } sub isValid { my $self = shift; my $ctxt = shift; my @elems = $$ctxt->getList(); my @valid_elems; if ($#elems+1 < $self->{POS}) { return; } push(@valid_elems, $elems[$self->{POS}-1]); $$ctxt->setList(@valid_elems); return 1; } ############################################################################## # # ContextOp - class to handle [...] ops # ############################################################################## package XML::Stream::XPath::ContextOp; use vars qw (@ISA); @ISA = ( "XML::Stream::XPath::Op" ); sub new { my $proto = shift; my $self = $proto->allocate("CONTEXT",""); $self->{OP} = shift; return $self; } sub isValid { my $self = shift; my $ctxt = shift; my @elems = $$ctxt->getList(); my @valid_elems; foreach my $elem (@elems) { my $tmp_ctxt = new XML::Stream::XPath::Value($elem); $tmp_ctxt->in_context(1); if ($self->{OP}->isValid(\$tmp_ctxt)) { push(@valid_elems,$elem); } } $$ctxt->setList(@valid_elems); if ($#valid_elems == -1) { return; } return 1; } sub display { my $self = shift; my $space = shift; $space = "" unless defined($space); print "${space}OP: type(CONTEXT) op: \n"; $self->{OP}->display("$space "); } ############################################################################## # # AllOp - class to handle // ops # ############################################################################## package XML::Stream::XPath::AllOp; use vars qw (@ISA); @ISA = ( "XML::Stream::XPath::Op" ); sub new { my $proto = shift; my $name = shift; my $self = $proto->allocate("ALL",$name); return $self; } sub isValid { my $self = shift; my $ctxt = shift; my @elems = $$ctxt->getList(); if ($#elems == -1) { return; } my @valid_elems; foreach my $elem (@elems) { push(@valid_elems,$self->descend($elem)); } $$ctxt->setList(@valid_elems); if ($#valid_elems == -1) { return; } return 1; } sub descend { my $self = shift; my $elem = shift; my @valid_elems; if (($self->{VALUE} eq "*") || (&XML::Stream::GetXMLData("tag",$elem) eq $self->{VALUE})) { push(@valid_elems,$elem); } foreach my $child (&XML::Stream::GetXMLData("child array",$elem,"*")) { push(@valid_elems,$self->descend($child)); } return @valid_elems; } ############################################################################## # # NodeOp - class to handle ops based on node names # ############################################################################## package XML::Stream::XPath::NodeOp; use vars qw (@ISA); @ISA = ( "XML::Stream::XPath::Op" ); sub new { my $proto = shift; my $name = shift; my $is_root = shift; $is_root = 0 unless defined($is_root); my $self = $proto->allocate("NODE",$name); $self->{ISROOT} = $is_root; return $self; } sub isValid { my $self = shift; my $ctxt = shift; if ($self->{ISROOT}) { my $elem = $$ctxt->getFirstElem(); if (&XML::Stream::GetXMLData("tag",$elem) ne $self->{VALUE}) { return; } return 1; } my @valid_elems; foreach my $elem ($$ctxt->getList()) { my $valid = 0; foreach my $child (&XML::Stream::GetXMLData("child array",$elem,"*")) { if (($self->{VALUE} eq "*") || (&XML::Stream::GetXMLData("tag",$child) eq $self->{VALUE})) { if ($$ctxt->in_context()) { $valid = 1; } else { push(@valid_elems,$child); } } } if ($valid) { push(@valid_elems,$elem); } } $$ctxt->setList(@valid_elems); if ($#valid_elems == -1) { return; } return 1; } sub calcStr { my $self = shift; my $elem = shift; return &XML::Stream::GetXMLData("value",$elem); } ############################################################################## # # EqualOp - class to handle [ x = y ] ops # ############################################################################## package XML::Stream::XPath::EqualOp; use vars qw (@ISA); @ISA = ( "XML::Stream::XPath::Op" ); sub new { my $proto = shift; my $self = $proto->allocate("EQUAL",""); $self->{OP_L} = shift; $self->{OP_R} = shift; return $self; } sub isValid { my $self = shift; my $ctxt = shift; my $tmp_ctxt = new XML::Stream::XPath::Value(); $tmp_ctxt->setList($$ctxt->getList()); $tmp_ctxt->in_context(0); if (!$self->{OP_L}->isValid(\$tmp_ctxt) || !$self->{OP_R}->isValid(\$tmp_ctxt)) { return; } my @valid_elems; foreach my $elem ($tmp_ctxt->getList) { if ($self->{OP_L}->calcStr($elem) eq $self->{OP_R}->calcStr($elem)) { push(@valid_elems,$elem); } } if ( $#valid_elems > -1) { @valid_elems = $$ctxt->getList(); } $$ctxt->setList(@valid_elems); if ($#valid_elems == -1) { return; } return 1; } sub display { my $self = shift; my $space = shift; $space = "" unless defined($space); print $space,"OP: type(EQUAL)\n"; print $space," op_l: "; $self->{OP_L}->display($space." "); print $space," op_r: "; $self->{OP_R}->display($space." "); } ############################################################################## # # NotEqualOp - class to handle [ x != y ] ops # ############################################################################## package XML::Stream::XPath::NotEqualOp; use vars qw (@ISA); @ISA = ( "XML::Stream::XPath::Op" ); sub new { my $proto = shift; my $self = $proto->allocate("NOTEQUAL",""); $self->{OP_L} = shift; $self->{OP_R} = shift; return $self; } sub isValid { my $self = shift; my $ctxt = shift; my $tmp_ctxt = new XML::Stream::XPath::Value(); $tmp_ctxt->setList($$ctxt->getList()); $tmp_ctxt->in_context(0); if (!$self->{OP_L}->isValid(\$tmp_ctxt) || !$self->{OP_R}->isValid(\$tmp_ctxt)) { return; } my @valid_elems; foreach my $elem ($tmp_ctxt->getList) { if ($self->{OP_L}->calcStr($elem) ne $self->{OP_R}->calcStr($elem)) { push(@valid_elems,$elem); } } if ( $#valid_elems > -1) { @valid_elems = $$ctxt->getList(); } $$ctxt->setList(@valid_elems); if ($#valid_elems == -1) { return; } return 1; } sub display { my $self = shift; my $space = shift; $space = "" unless defined($space); print $space,"OP: type(NOTEQUAL)\n"; print $space," op_l: "; $self->{OP_L}->display($space." "); print $space," op_r: "; $self->{OP_R}->display($space." "); } ############################################################################## # # AttributeOp - class to handle @foo ops. # ############################################################################## package XML::Stream::XPath::AttributeOp; use vars qw (@ISA); @ISA = ( "XML::Stream::XPath::Op" ); sub new { my $proto = shift; my $name = shift; my $self = $proto->allocate("ATTRIBUTE",$name); return $self; } sub isValid { my $self = shift; my $ctxt = shift; my @elems = $$ctxt->getList(); my @valid_elems; my @values; my %attribs; foreach my $elem (@elems) { if ($self->{VALUE} ne "*") { if (&XML::Stream::GetXMLData("value",$elem,"",$self->{VALUE})) { $self->{VAL} = $self->calcStr($elem); push(@valid_elems,$elem); push(@values,$self->{VAL}); } } else { my %attrib = &XML::Stream::GetXMLData("attribs",$elem); if (scalar(keys(%attrib)) > 0) { push(@valid_elems,$elem); foreach my $key (keys(%attrib)) { $attribs{$key} = $attrib{$key}; } } } } $$ctxt->setList(@valid_elems); $$ctxt->setValues(@values); $$ctxt->setAttribs(%attribs); if ($#valid_elems == -1) { return; } return 1; } sub getValue { my $self = shift; return $self->{VAL}; } sub calcStr { my $self = shift; my $elem = shift; return &XML::Stream::GetXMLData("value",$elem,"",$self->{VALUE}); } ############################################################################## # # AndOp - class to handle [ .... and .... ] ops # ############################################################################## package XML::Stream::XPath::AndOp; use vars qw (@ISA); @ISA = ( "XML::Stream::XPath::Op" ); sub new { my $proto = shift; my $self = $proto->allocate("AND","and"); $self->{OP_L} = shift; $self->{OP_R} = shift; return $self; } sub isValid { my $self = shift; my $ctxt = shift; my $opl = $self->{OP_L}->isValid($ctxt); my $opr = $self->{OP_R}->isValid($ctxt); if ($opl && $opr) { return 1; } else { return; } } sub display { my $self = shift; my $space = shift; $space = "" unless defined($space); print $space,"OP: type(AND)\n"; print $space," op_l: \n"; $self->{OP_L}->display($space." "); print $space," op_r: \n"; $self->{OP_R}->display($space." "); } ############################################################################## # # OrOp - class to handle [ .... or .... ] ops # ############################################################################## package XML::Stream::XPath::OrOp; use vars qw (@ISA); @ISA = ( "XML::Stream::XPath::Op" ); sub new { my $proto = shift; my $self = $proto->allocate("OR","or"); $self->{OP_L} = shift; $self->{OP_R} = shift; return $self; } sub isValid { my $self = shift; my $ctxt = shift; my @elems = $$ctxt->getList(); my @valid_elems; foreach my $elem (@elems) { my $tmp_ctxt_l = new XML::Stream::XPath::Value($elem); $tmp_ctxt_l->in_context(1); my $tmp_ctxt_r = new XML::Stream::XPath::Value($elem); $tmp_ctxt_r->in_context(1); my $opl = $self->{OP_L}->isValid(\$tmp_ctxt_l); my $opr = $self->{OP_R}->isValid(\$tmp_ctxt_r); if ($opl || $opr) { push(@valid_elems,$elem); } } $$ctxt->setList(@valid_elems); if ($#valid_elems == -1) { return; } return 1; } sub display { my $self = shift; my $space = shift; $space = "" unless defined($space); print "${space}OP: type(OR)\n"; print "$space op_l: "; $self->{OP_L}->display("$space "); print "$space op_r: "; $self->{OP_R}->display("$space "); } ############################################################################## # # FunctionOp - class to handle xxxx(...) ops # ############################################################################## package XML::Stream::XPath::FunctionOp; use vars qw (@ISA); @ISA = ( "XML::Stream::XPath::Op" ); sub new { my $proto = shift; my $function = shift; my $self = $proto->allocate("FUNCTION",$function); $self->{CLOSED} = 0; return $self; } sub addArg { my $self = shift; my $arg = shift; push(@{$self->{ARGOPS}},$arg); } sub isValid { my $self = shift; my $ctxt = shift; my $result; eval("\$result = &{\$XML::Stream::XPath::FUNCTIONS{\$self->{VALUE}}}(\$ctxt,\@{\$self->{ARGOPS}});"); return $result; } sub calcStr { my $self = shift; my $elem = shift; my $result; eval("\$result = &{\$XML::Stream::XPath::VALUES{\$self->{VALUE}}}(\$elem);"); return $result; } sub display { my $self = shift; my $space = shift; $space = "" unless defined($space); print $space,"OP: type(FUNCTION)\n"; print $space," $self->{VALUE}(\n"; foreach my $arg (@{$self->{ARGOPS}}) { print $arg,"\n"; $arg->display($space." "); } print "$space )\n"; } sub function_name { my $ctxt = shift; my (@args) = @_; my @elems = $$ctxt->getList(); my @valid_elems; my @valid_values; foreach my $elem (@elems) { my $text = &value_name($elem); if (defined($text)) { push(@valid_elems,$elem); push(@valid_values,$text); } } $$ctxt->setList(@valid_elems); $$ctxt->setValues(@valid_values); if ($#valid_elems == -1) { return; } return 1; } sub function_not { my $ctxt = shift; my (@args) = @_; my @elems = $$ctxt->getList(); my @valid_elems; foreach my $elem (@elems) { my $tmp_ctxt = new XML::Stream::XPath::Value($elem); $tmp_ctxt->in_context(1); if (!($args[0]->isValid(\$tmp_ctxt))) { push(@valid_elems,$elem); } } $$ctxt->setList(@valid_elems); if ($#valid_elems == -1) { return; } return 1; } sub function_text { my $ctxt = shift; my (@args) = @_; my @elems = $$ctxt->getList(); my @valid_elems; my @valid_values; foreach my $elem (@elems) { my $text = &value_text($elem); if (defined($text)) { push(@valid_elems,$elem); push(@valid_values,$text); } } $$ctxt->setList(@valid_elems); $$ctxt->setValues(@valid_values); if ($#valid_elems == -1) { return; } return 1; } sub function_startswith { my $ctxt = shift; my (@args) = @_; my @elems = $$ctxt->getList(); my @valid_elems; foreach my $elem (@elems) { my $val1 = $args[0]->calcStr($elem); my $val2 = $args[1]->calcStr($elem); if (substr($val1,0,length($val2)) eq $val2) { push(@valid_elems,$elem); } } $$ctxt->setList(@valid_elems); if ($#valid_elems == -1) { return; } return 1; } sub value_name { my $elem = shift; return &XML::Stream::GetXMLData("tag",$elem); } sub value_text { my $elem = shift; return &XML::Stream::GetXMLData("value",$elem); } $XML::Stream::XPath::FUNCTIONS{'name'} = \&function_name; $XML::Stream::XPath::FUNCTIONS{'not'} = \&function_not; $XML::Stream::XPath::FUNCTIONS{'text'} = \&function_text; $XML::Stream::XPath::FUNCTIONS{'starts-with'} = \&function_startswith; $XML::Stream::XPath::VALUES{'name'} = \&value_name; $XML::Stream::XPath::VALUES{'text'} = \&value_text; 1; XML-Stream-1.23/lib/XML/Stream/XPath/Query.pm0000644000175000017500000002424411321523765021161 0ustar dapatrickdapatrick############################################################################## # # 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. # # Jabber # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package XML::Stream::XPath::Query; use 5.008; use strict; use Carp; use vars qw( $VERSION ); $VERSION = "1.23"; sub new { my $proto = shift; my $self = { }; bless($self,$proto); $self->{TOKENS} = [ '/','[',']','@','"',"'",'=','!','(',')',':',' ',',']; $self->{QUERY} = shift; if (!defined($self->{QUERY}) || ($self->{QUERY} eq "")) { confess("No query string specified"); } $self->parseQuery(); return $self; } sub getNextToken { my $self = shift; my $pos = shift; my @toks = grep{ $_ eq substr($self->{QUERY},$$pos,1)} @{$self->{TOKENS}}; while( $#toks == -1 ) { $$pos++; if ($$pos > length($self->{QUERY})) { $$pos = length($self->{QUERY}); return 0; } @toks = grep{ $_ eq substr($self->{QUERY},$$pos,1)} @{$self->{TOKENS}}; } return $toks[0]; } sub getNextIdentifier { my $self = shift; my $pos = shift; my $sp = $$pos; $self->getNextToken($pos); return substr($self->{QUERY},$sp,$$pos-$sp); } sub getOp { my $self = shift; my $pos = shift; my $in_context = shift; $in_context = 0 unless defined($in_context); my $ret_op; my $loop = 1; while( $loop ) { my $pos_start = $$pos; my $token = $self->getNextToken($pos); if (($token eq "0") && $in_context) { return; } my $token_start = ++$$pos; my $ident; if (defined($token)) { if ($pos_start != ($token_start-1)) { $$pos = $pos_start; my $temp_ident = $self->getNextIdentifier($pos); $ret_op = new XML::Stream::XPath::NodeOp($temp_ident,"0"); } elsif ($token eq "/") { if (substr($self->{QUERY},$token_start,1) eq "/") { $$pos++; my $temp_ident = $self->getNextIdentifier($pos); $ret_op = new XML::Stream::XPath::AllOp($temp_ident); } else { my $temp_ident = $self->getNextIdentifier($pos); if ($temp_ident ne "") { $ret_op = new XML::Stream::XPath::NodeOp($temp_ident,($pos_start == 0 ? "1" : "0")); } } } elsif ($token eq "\@") { $ret_op = new XML::Stream::XPath::AttributeOp($self->getNextIdentifier($pos)); } elsif ($token eq "]") { if ($in_context eq "[") { $ret_op = pop(@{$self->{OPS}}); $in_context = 0; } else { confess("Found ']' but not in context"); return; } } elsif (($token eq "\"") || ($token eq "\'")) { $$pos = index($self->{QUERY},$token,$token_start); $ret_op = new XML::Stream::XPath::Op("LITERAL",substr($self->{QUERY},$token_start,$$pos-$token_start)); $$pos++; } elsif ($token eq " ") { $ident = $self->getNextIdentifier($pos); if ($ident eq "and") { $$pos++; my $tmp_op = $self->getOp($pos,$in_context); if (!defined($tmp_op)) { confess("Invalid 'and' operation"); return; } $ret_op = new XML::Stream::XPath::AndOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op); $in_context = 0; pop(@{$self->{OPS}}); } elsif ($ident eq "or") { $$pos++; my $tmp_op = $self->getOp($pos,$in_context); if (!defined($tmp_op)) { confess("Invalid 'or' operation"); return; } $ret_op = new XML::Stream::XPath::OrOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op); $in_context = 0; pop(@{$self->{OPS}}); } } elsif ($token eq "[") { if ($self->getNextToken($pos) eq "]") { if ($$pos == $token_start) { confess("Nothing in the []"); return; } $$pos = $token_start; my $val = $self->getNextIdentifier($pos); if ($val =~ /^\d+$/) { $ret_op = new XML::Stream::XPath::PositionOp($val); $$pos++; } else { $$pos = $pos_start + 1; $ret_op = new XML::Stream::XPath::ContextOp($self->getOp($pos,$token)); } } else { $$pos = $pos_start + 1; $ret_op = new XML::Stream::XPath::ContextOp($self->getOp($pos,$token)); } } elsif ($token eq "(") { #------------------------------------------------------------- # The function name would have been mistaken for a NodeOp. # Pop it off the back and get the function name. #------------------------------------------------------------- my $op = pop(@{$self->{OPS}}); if ($op->getType() ne "NODE") { confess("No function name specified."); } my $function = $op->getValue(); if (!exists($XML::Stream::XPath::FUNCTIONS{$function})) { confess("Undefined function \"$function\""); } $ret_op = new XML::Stream::XPath::FunctionOp($function); my $op_pos = $#{$self->{OPS}} + 1; $self->getOp($pos,$token); foreach my $arg ($op_pos..$#{$self->{OPS}}) { $ret_op->addArg($self->{OPS}->[$arg]); } splice(@{$self->{OPS}},$op_pos); } elsif ($token eq ")") { if ($in_context eq "(") { $ret_op = undef; $in_context = 0; } else { confess("Found ')' but not in context"); } } elsif ($token eq ",") { if ($in_context ne "(") { confess("Found ',' but not in a function"); } } elsif ($token eq "=") { my $tmp_op; while(!defined($tmp_op)) { $tmp_op = $self->getOp($pos); } $ret_op = new XML::Stream::XPath::EqualOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op); pop(@{$self->{OPS}}); } elsif ($token eq "!") { if (substr($self->{QUERY},$token_start,1) ne "=") { confess("Badly formed !="); } $$pos++; my $tmp_op; while(!defined($tmp_op)) { $tmp_op = $self->getOp($pos); } $ret_op = new XML::Stream::XPath::NotEqualOp($self->{OPS}->[$#{$self->{OPS}}],$tmp_op); pop(@{$self->{OPS}}); } else { confess("Unhandled \"$token\""); } if ($in_context) { if (defined($ret_op)) { push(@{$self->{OPS}},$ret_op); } $ret_op = undef; } } else { confess("Token undefined"); } $loop = 0 unless $in_context; } return $ret_op; } sub parseQuery { my $self = shift; my $query = shift; my $op; my $pos = 0; while($pos < length($self->{QUERY})) { $op = $self->getOp(\$pos); if (defined($op)) { push(@{$self->{OPS}},$op); } } #foreach my $op (@{$self->{OPS}}) #{ # $op->display(); #} return 1; } sub execute { my $self = shift; my $root = shift; my $ctxt = new XML::Stream::XPath::Value($root); foreach my $op (@{$self->{OPS}}) { if (!$op->isValid(\$ctxt)) { $ctxt->setValid(0); return $ctxt; } } $ctxt->setValid(1); return $ctxt; } sub check { my $self = shift; my $root = shift; my $ctxt = $self->execute($root); return $ctxt->check(); } 1; XML-Stream-1.23/lib/XML/Stream/Tree.pm0000644000175000017500000006176611321524646017740 0ustar dapatrickdapatrick############################################################################## # # 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. # # Jabber # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package XML::Stream::Tree; =head1 NAME XML::Stream::Tree - Functions to make building and parsing the tree easier to work with. =head1 SYNOPSIS Just a collection of functions that do not need to be in memory if you choose one of the other methods of data storage. =head1 FORMAT The result of parsing: Hello thereHowdydo would be: Tag Content ================================================================== [foo, [{}, head, [{id => "a"}, 0, "Hello ", em, [{}, 0, "there" ] ], bar, [{}, 0, "Howdy", ref, [{}] ], 0, "do" ] ] The above was copied from the XML::Parser man page. Many thanks to Larry and Clark. =head1 AUTHOR By Ryan Eatmon in March 2001 for http://jabber.org/ Currently maintained by Darian Anthony Patrick. =head1 COPYRIGHT This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use vars qw( $VERSION $LOADED ); $VERSION = "1.23"; $LOADED = 1; ############################################################################## # # _handle_element - handles the main tag elements sent from the server. # On an open tag it creates a new XML::Parser::Tree so # that _handle_cdata and _handle_element can add data # and tags to it later. # ############################################################################## sub _handle_element { my $self; $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); my ($sax, $tag, %att) = @_; my $sid = $sax->getSID(); $self->debug(2,"_handle_element: sid($sid) sax($sax) tag($tag) att(",%att,")"); my @NEW; if($#{$self->{SIDS}->{$sid}->{tree}} < 0) { push @{$self->{SIDS}->{$sid}->{tree}}, $tag; } else { push @{ $self->{SIDS}->{$sid}->{tree}[ $#{$self->{SIDS}->{$sid}->{tree}}]}, $tag; } push @NEW, \%att; push @{$self->{SIDS}->{$sid}->{tree}}, \@NEW; } ############################################################################## # # _handle_cdata - handles the CDATA that is encountered. Also, in the # spirit of XML::Parser::Tree it combines any sequential # CDATA into one tag. # ############################################################################## sub _handle_cdata { my $self; $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); my ($sax, $cdata) = @_; my $sid = $sax->getSID(); $self->debug(2,"_handle_cdata: sid($sid) sax($sax) cdata($cdata)"); return if ($#{$self->{SIDS}->{$sid}->{tree}} == -1); $self->debug(2,"_handle_cdata: sax($sax) cdata($cdata)"); my $pos = $#{$self->{SIDS}->{$sid}->{tree}}; $self->debug(2,"_handle_cdata: pos($pos)"); if ($pos > 0 && $self->{SIDS}->{$sid}->{tree}[$pos - 1] eq "0") { $self->debug(2,"_handle_cdata: append cdata"); $self->{SIDS}->{$sid}->{tree}[$pos - 1] .= $cdata; } else { $self->debug(2,"_handle_cdata: new cdata"); push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, 0; push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, $cdata; } } ############################################################################## # # _handle_close - when we see a close tag we need to pop the last element # from the list and push it onto the end of the previous # element. This is how we build our hierarchy. # ############################################################################## sub _handle_close { my $self; $self = $_[0] if (ref($_[0]) eq "XML::Stream::Parser"); $self = shift unless (ref($_[0]) eq "XML::Stream::Parser"); my ($sax, $tag) = @_; my $sid = $sax->getSID(); $self->debug(2,"_handle_close: sid($sid) sax($sax) tag($tag)"); my $CLOSED = pop @{$self->{SIDS}->{$sid}->{tree}}; $self->debug(2,"_handle_close: check(",$#{$self->{SIDS}->{$sid}->{tree}},")"); if ($#{$self->{SIDS}->{$sid}->{tree}} == -1) { if ($self->{SIDS}->{$sid}->{rootTag} ne $tag) { $self->{SIDS}->{$sid}->{streamerror} = "Root tag mis-match: <$self->{SIDS}->{$sid}->{rootTag}> ... \n"; } return; } if($#{$self->{SIDS}->{$sid}->{tree}} < 1) { push @{$self->{SIDS}->{$sid}->{tree}}, $CLOSED; if (ref($self) ne "XML::Stream::Parser") { my $stream_prefix = $self->StreamPrefix($sid); if(defined($self->{SIDS}->{$sid}->{tree}->[0]) && ($self->{SIDS}->{$sid}->{tree}->[0] =~ /^${stream_prefix}\:/)) { my @tree = @{$self->{SIDS}->{$sid}->{tree}}; $self->{SIDS}->{$sid}->{tree} = []; $self->ProcessStreamPacket($sid,\@tree); } else { my @tree = @{$self->{SIDS}->{$sid}->{tree}}; $self->{SIDS}->{$sid}->{tree} = []; my @special = &XML::Stream::XPath( \@tree, '[@xmlns="'.&XML::Stream::ConstXMLNS("xmpp-sasl").'" or @xmlns="'.&XML::Stream::ConstXMLNS("xmpp-tls").'"]' ); if ($#special > -1) { my $xmlns = &GetXMLData("value",\@tree,"","xmlns"); $self->ProcessSASLPacket($sid,\@tree) if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-sasl")); $self->ProcessTLSPacket($sid,\@tree) if ($xmlns eq &XML::Stream::ConstXMLNS("xmpp-tls")); } else { &{$self->{CB}->{node}}($sid,\@tree); } } } } else { push @{$self->{SIDS}->{$sid}->{tree}[$#{$self->{SIDS}->{$sid}->{tree}}]}, $CLOSED; } } ############################################################################## # # SetXMLData - takes a host of arguments and sets a portion of the specified # XML::Parser::Tree object with that data. The function works # in two modes "single" or "multiple". "single" denotes that # the function should locate the current tag that matches this # data and overwrite it's contents with data passed in. # "multiple" denotes that a new tag should be created even if # others exist. # # type - single or multiple # XMLTree - pointer to XML::Stream Tree object # tag - name of tag to create/modify (if blank assumes # working with top level tag) # data - CDATA to set for tag # attribs - attributes to ADD to tag # ############################################################################## sub SetXMLData { my ($type,$XMLTree,$tag,$data,$attribs) = @_; my ($key); if ($tag ne "") { if ($type eq "single") { my ($child); foreach $child (1..$#{$$XMLTree[1]}) { if ($$XMLTree[1]->[$child] eq $tag) { if ($data ne "") { #todo: add code to handle writing the cdata again and appending it. $$XMLTree[1]->[$child+1]->[1] = 0; $$XMLTree[1]->[$child+1]->[2] = $data; } foreach $key (keys(%{$attribs})) { $$XMLTree[1]->[$child+1]->[0]->{$key} = $$attribs{$key}; } return; } } } $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = $tag; $$XMLTree[1]->[($#{$$XMLTree[1]}+1)]->[0] = {}; foreach $key (keys(%{$attribs})) { $$XMLTree[1]->[$#{$$XMLTree[1]}]->[0]->{$key} = $$attribs{$key}; } if ($data ne "") { $$XMLTree[1]->[$#{$$XMLTree[1]}]->[1] = 0; $$XMLTree[1]->[$#{$$XMLTree[1]}]->[2] = $data; } } else { foreach $key (keys(%{$attribs})) { $$XMLTree[1]->[0]->{$key} = $$attribs{$key}; } if ($data ne "") { if (($#{$$XMLTree[1]} > 0) && ($$XMLTree[1]->[($#{$$XMLTree[1]}-1)] eq "0")) { $$XMLTree[1]->[$#{$$XMLTree[1]}] .= $data; } else { $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = 0; $$XMLTree[1]->[($#{$$XMLTree[1]}+1)] = $data; } } } } ############################################################################## # # GetXMLData - takes a host of arguments and returns various data structures # that match them. # # type - "existence" - returns 1 or 0 if the tag exists in the # top level. # "value" - returns either the CDATA of the tag, or the # value of the attribute depending on which is # sought. This ignores any mark ups to the data # and just returns the raw CDATA. # "value array" - returns an array of strings representing # all of the CDATA in the specified tag. # This ignores any mark ups to the data # and just returns the raw CDATA. # "tree" - returns an XML::Parser::Tree object with the # specified tag as the root tag. # "tree array" - returns an array of XML::Parser::Tree # objects each with the specified tag as # the root tag. # "child array" - returns a list of all children nodes # not including CDATA nodes. # "attribs" - returns a hash with the attributes, and # their values, for the things that match # the parameters # "count" - returns the number of things that match # the arguments # "tag" - returns the root tag of this tree # XMLTree - pointer to XML::Parser::Tree object # tag - tag to pull data from. If blank then the top level # tag is accessed. # attrib - attribute value to retrieve. Ignored for types # "value array", "tree", "tree array". If paired # with value can be used to filter tags based on # attributes and values. # value - only valid if an attribute is supplied. Used to # filter for tags that only contain this attribute. # Useful to search through multiple tags that all # reference different name spaces. # ############################################################################## sub GetXMLData { my ($type,$XMLTree,$tag,$attrib,$value) = @_; $tag = "" if !defined($tag); $attrib = "" if !defined($attrib); $value = "" if !defined($value); my $skipthis = 0; #--------------------------------------------------------------------------- # Check if a child tag in the root tag is being requested. #--------------------------------------------------------------------------- if ($tag ne "") { my $count = 0; my @array; foreach my $child (1..$#{$$XMLTree[1]}) { next if (($child/2) !~ /\./); if (($$XMLTree[1]->[$child] eq $tag) || ($tag eq "*")) { next if (ref($$XMLTree[1]->[$child]) eq "ARRAY"); #--------------------------------------------------------------------- # Filter out tags that do not contain the attribute and value. #--------------------------------------------------------------------- next if (($value ne "") && ($attrib ne "") && exists($$XMLTree[1]->[$child+1]->[0]->{$attrib}) && ($$XMLTree[1]->[$child+1]->[0]->{$attrib} ne $value)); next if (($attrib ne "") && ((ref($$XMLTree[1]->[$child+1]) ne "ARRAY") || !exists($$XMLTree[1]->[$child+1]->[0]->{$attrib}))); #--------------------------------------------------------------------- # Check for existence #--------------------------------------------------------------------- if ($type eq "existence") { return 1; } #--------------------------------------------------------------------- # Return the raw CDATA value without mark ups, or the value of the # requested attribute. #--------------------------------------------------------------------- if ($type eq "value") { if ($attrib eq "") { my $str = ""; my $next = 0; my $index; foreach $index (1..$#{$$XMLTree[1]->[$child+1]}) { if ($next == 1) { $next = 0; next; } if ($$XMLTree[1]->[$child+1]->[$index] eq "0") { $str .= $$XMLTree[1]->[$child+1]->[$index+1]; $next = 1; } } return $str; } return $$XMLTree[1]->[$child+1]->[0]->{$attrib} if (exists $$XMLTree[1]->[$child+1]->[0]->{$attrib}); } #--------------------------------------------------------------------- # Return an array of values that represent the raw CDATA without # mark up tags for the requested tags. #--------------------------------------------------------------------- if ($type eq "value array") { if ($attrib eq "") { my $str = ""; my $next = 0; my $index; foreach $index (1..$#{$$XMLTree[1]->[$child+1]}) { if ($next == 1) { $next = 0; next; } if ($$XMLTree[1]->[$child+1]->[$index] eq "0") { $str .= $$XMLTree[1]->[$child+1]->[$index+1]; $next = 1; } } push(@array,$str); } else { push(@array,$$XMLTree[1]->[$child+1]->[0]->{$attrib}) if (exists $$XMLTree[1]->[$child+1]->[0]->{$attrib}); } } #--------------------------------------------------------------------- # Return a pointer to a new XML::Parser::Tree object that has the # requested tag as the root tag. #--------------------------------------------------------------------- if ($type eq "tree") { my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] ); return @tree; } #--------------------------------------------------------------------- # Return an array of pointers to XML::Parser::Tree objects that have # the requested tag as the root tags. #--------------------------------------------------------------------- if ($type eq "tree array") { my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] ); push(@array,\@tree); } #--------------------------------------------------------------------- # Return a count of the number of tags that match #--------------------------------------------------------------------- if ($type eq "count") { if ($$XMLTree[1]->[$child] eq "0") { $skipthis = 1; next; } if ($skipthis == 1) { $skipthis = 0; next; } $count++; } #--------------------------------------------------------------------- # Return a count of the number of tags that match #--------------------------------------------------------------------- if ($type eq "child array") { my @tree = ( $$XMLTree[1]->[$child] , $$XMLTree[1]->[$child+1] ); push(@array,\@tree) if ($tree[0] ne "0"); } #--------------------------------------------------------------------- # Return the attribute hash that matches this tag #--------------------------------------------------------------------- if ($type eq "attribs") { return (%{$$XMLTree[1]->[$child+1]->[0]}); } } } #------------------------------------------------------------------------- # If we are returning arrays then return array. #------------------------------------------------------------------------- if (($type eq "tree array") || ($type eq "value array") || ($type eq "child array")) { return @array; } #------------------------------------------------------------------------- # If we are returning then count, then do so #------------------------------------------------------------------------- if ($type eq "count") { return $count; } } else { #------------------------------------------------------------------------- # This is the root tag, so handle things a level up. #------------------------------------------------------------------------- #------------------------------------------------------------------------- # Return the raw CDATA value without mark ups, or the value of the # requested attribute. #------------------------------------------------------------------------- if ($type eq "value") { if ($attrib eq "") { my $str = ""; my $next = 0; my $index; foreach $index (1..$#{$$XMLTree[1]}) { if ($next == 1) { $next = 0; next; } if ($$XMLTree[1]->[$index] eq "0") { $str .= $$XMLTree[1]->[$index+1]; $next = 1; } } return $str; } return $$XMLTree[1]->[0]->{$attrib} if (exists $$XMLTree[1]->[0]->{$attrib}); } #------------------------------------------------------------------------- # Return a pointer to a new XML::Parser::Tree object that has the # requested tag as the root tag. #------------------------------------------------------------------------- if ($type eq "tree") { my @tree = @{$$XMLTree}; return @tree; } #------------------------------------------------------------------------- # Return the 1 if the specified attribute exists in the root tag. #------------------------------------------------------------------------- if ($type eq "existence") { return 1 if (($attrib ne "") && (exists($$XMLTree[1]->[0]->{$attrib}))); } #------------------------------------------------------------------------- # Return the attribute hash that matches this tag #------------------------------------------------------------------------- if ($type eq "attribs") { return %{$$XMLTree[1]->[0]}; } #------------------------------------------------------------------------- # Return the tag of this node #------------------------------------------------------------------------- if ($type eq "tag") { return $$XMLTree[0]; } } #--------------------------------------------------------------------------- # Return 0 if this was a request for existence, or "" if a request for # a "value", or [] for "tree", "value array", and "tree array". #--------------------------------------------------------------------------- return 0 if ($type eq "existence"); return "" if ($type eq "value"); return []; } ############################################################################## # # BuildXML - takes an XML::Parser::Tree object and builds the XML string # that it represents. # ############################################################################## sub BuildXML { my ($parseTree,$rawXML) = @_; return "" if $#{$parseTree} == -1; my $str = ""; if (ref($parseTree->[0]) eq "") { if ($parseTree->[0] eq "0") { return &XML::Stream::EscapeXML($parseTree->[1]); } $str = "<".$parseTree->[0]; foreach my $att (sort {$a cmp $b} keys(%{$parseTree->[1]->[0]})) { $str .= " ".$att."='".&XML::Stream::EscapeXML($parseTree->[1]->[0]->{$att})."'"; } if (($#{$parseTree->[1]} > 0) || (defined($rawXML) && ($rawXML ne ""))) { $str .= ">"; my $index = 1; while($index <= $#{$parseTree->[1]}) { my @newTree = ( $parseTree->[1]->[$index], $parseTree->[1]->[$index+1] ); $str .= &XML::Stream::Tree::BuildXML(\@newTree); $index += 2; } $str .= $rawXML if defined($rawXML); $str .= "[0].">"; } else { $str .= "/>"; } } return $str; } ############################################################################## # # XML2Config - takes an XML data tree and turns it into a hash of hashes. # This only works for certain kinds of XML trees like this: # # # 1 # # foo # # 5 # # # The resulting hash would be: # # $hash{bar} = 1; # $hash{x}->{y} = "foo"; # $hash{z} = 5; # # Good for config files. # ############################################################################## sub XML2Config { my ($XMLTree) = @_; my %hash; foreach my $tree (&XML::Stream::GetXMLData("tree array",$XMLTree,"*")) { if ($tree->[0] eq "0") { return $tree->[1] unless ($tree->[1] =~ /^\s*$/); } else { if (&XML::Stream::GetXMLData("count",$XMLTree,$tree->[0]) > 1) { push(@{$hash{$tree->[0]}},&XML::Stream::XML2Config($tree)); } else { $hash{$tree->[0]} = &XML::Stream::XML2Config($tree); } } } return \%hash; } 1; XML-Stream-1.23/CHANGES0000644000175000017500000002136411317216054015017 0ustar dapatrickdapatrick1.23 ==== - RT#17484 Handle servers which re-use stream ID - RT#18711 Update link to XML Streams doc - RT#12977 Require perl >= 5.8.0 - RT#19415 Use jabber.org for tests - RT#21932 Fix authname for Google Talk SASL auth - RT#39098 Make dependencies more explicit - RT#24817 Merge and massage of toddr's SASL fix - RT#36864 Fake select on filehandles on win32 - RT#31215 Test and fix for XML node copying issue - RT#17325 Fix and test for infinite loop on quotes 1.22 ==== - Using Encode module to handle utf encoding and decoding. I cannot just put the socket into utf8 because IO::Socket::SSL does not support binmode. So I'm calling decode_utf8() before returning the Read string, and encode_utf8() before writing the Send string. - Fixed SASL PLAIN authentication. 1.21 ==== - Sigh... Screwed up the CPAN release... again... 1.20 ==== - Ok... dang it. Another minor tweak to fix CPAN. 1.19 ==== - Minor release bug. Forgot to include the prereqs for Authen::SASL and MIME::Base4. 1.18 ==== - Added initial cut at XMPP 1.0 support. - Fixed timeout for Connect(). It was horribly broken and in efficient. Thanks to Jesper Krogh. - Added timeout to socket creation. 1.17 ==== - Added patch to make the Process a little faster by putting the sleeps into the can_read() calls so that you don't have to delay even a few micro seconds when you get new XML. (Evan Prodromou) - Added SRV lookup support for Connect via Net::DNS. - Changed the select calls when blocking to can_read calls so that we can wake up when there is data, and not just after a certain period of time. Thanks to Evan Prodromou. - Interesting bug with Broken Pipes. 1.16 ==== - Upgraded the XPath engine to a more extensible and robust design. - To get tests to work 100% I have to get better determination on the BuildXML functions. So fomr this point on, all attributes are printed in alphabetical order. - Fixed bug in Parser with not being supported. - Changed BuildXML for Tree. You have to pass it a ref and not an array. That was to make the rawXML thing work better. - Added the ability to add raw XML at the BuildXML call. - Added remove_cdata method to Node. - Added methods to Node to make calls easier (XPath, GetXML). 1.15 ==== - Added XPath function and support for most of the abbreviated xpaths. - Added new XML::Stream::Node type. This behaves more like a you would think an XML node would behave. - Added a NONBLOCKING variable to control if the parser blocks or does not block. This might cause some problems, but it also might open some new doors. We will see. - Upped buffer size by 4x for second party fix. - Added code to handle tracking the last activity. - Fixed Disconnect bug where is would not clean up the environment well enough. - Added check for version of IO::Socket::SSL since it is not a required module. - Added check before trying to convert a socket to SSL. - Removed some warnings about unintialized strings. - Added tests for make test. 1.14 ==== - Fixed slow execution due to a sleep where there shouldn't be a sleep. - Added OpenFile() way to parse a stream. It takes the same kind of arguments that open() takes, so you can parse the stream output from a command or a file and pretend that it's a stream. It will ignore the outer most tag and pretend that it's a tag. - Fixed documentation to reflect the SID. - Get "value array" with attrib fetches the same attrib from the macthing nodes. 1.13 ==== - Fixed bug in Parser with entities getting split by reads and not interpreted properly. - Moved IO::Select requirement to 1.13 per a bug report from datawrangler. - Added XML2Config function to handle parsing config.xml files. - Fixed bug in the Parser parse and parsefile functions. 1.12 ==== - Fixed SSL bug. - Added support for the new HTTP::ProxyAutoConfig from Netscape. - Fixed logic for proxy servers. (This is gonna break for someone... I can just feel it.) - Added SSL support in for both tcpip and http connections. - Removed support for native Unicode under perl 5.6. It was causing a big memory leak that the Unicode::String module does not incur. This means that the Unicode::String module is now a requirement for XML::Stream. - Added in support for connecting via HTTP. This takes a special server that can keep the connection alive as the HTTP connection is setup only once and is kept opne while you send and receive. This allows you to connect through proxy servers. - More tweaks for memory usage and speed ups. - Added in a new XML sotrage format to try and save space. It's a hash representation of the entire XML document. XML::Parser::Tree uses arrays of arrays and arrays of hashes which can consume memory in very short order. It was a good starting point, but it's time to move on. Se the INFO doc for more info on the new format. (Not done yet.) - Added GetXMLData, SetXMLData, BuildXML, and EscapeXML which was originally written for the Net::Jabber modules but realized that they made more sense in here. =P 1.11 ==== - Added in a module for DTD parsing. This will hopefully lead to verification of XML Streams based off of DTD. - Fixed bug in the Process function caused by the new way of handling multiple connections with detecting a broken connection. - Added code to handle listening for incoming connections on a port for a namespace. THIS IS STILL UNDER DEVELOPMENT! - Added XML::Stream::Parser to replace XML::Parser. - Fixed bug in the timeout code. 1.10 ==== - Added SetCallBacks function to repleace OnNode and provide other hooks for more functions. - Fixed initial connect function and error handling. 1.09 ==== - Updated Connect to handle changing the values of the to and from attributes directly from the function call. (Useful for proxying.) 1.08 ==== - Added boiler plate comments for the LGPL. - Added code to Send to check if the connection was lost. This fixes a Broken Pipe error that I was seeing when the program tried to write to a socket that was closed. 1.07 ==== - Added code to handle not only connecting over TCP/IP but over STDIN/STDOUT (for the new Jabber server). - Added code to handle keeping the connection alive over connections that drop the connection after a period of inactivity. 1.06 ==== - Fixed bug where Process(0) would still sleep for a short time and cause those fast loops to take longer than they should. - Added Unicode support. When you build the tree, make sure that it's latin 1 you are speaking. It's then up to the sender to ensure that the outgoing data is utf8. - Added timestamp support to debug. - STREAMERROR is now local to an object instantiaion instead of the namespace. This helps when you get an error and then grab a new object and want to connect again. 1.05 ==== - Fixed sport where Stream would die if it could not resolve your full hostname. Now it just reverts back to the result of hostname() if it can' look up the full name. - Initialized some variables to get rid of warnings with perl -w. 1.04 ==== - Changed version scheme to allow Perl to check for it. 1.0c ==== - I think I got the bug in ParseStream that removes the parse coming in while a parse is already in progress. - Fixed major bug in Process. If you got a tag in the middle of the tag it would cause an XML error. - Also, if another parse came in during another parse, the second parse tree would get built under the current parse tree and everything would grind to a halt. 1.0b ==== - Improved error handling by creating GetErrorCode and SetErrorCode. These functions allow the caller to get some information about why Process or Connect returned undef. - Added error checking if a is sent. This will call SetErrorCode and return undef. 1.0a ==== - Version bump. - Changed method of handling timeouts in the Connect and Process block. The timeout from the Connect is no longer remembered in the Process and used. This method has improved the speed of the module greatly. - Fixed bug where the Process was not properly handling a connection breakdown. It now returns undef, or "", when the server dies or the connection is dropped. 0.1b ==== - Added XML::Stream::Namespace to make writting Perl modules for other namepsaces possible. (This is highly alpha...) - Added Disconnect function to send closing tag and shut the stream down. - Added documentation list of methods in Stream.pm. 0.1a ==== - First version. - Supports connecting to a server, opening a stream, and receiving from that stream. XML-Stream-1.23/META.yml0000644000175000017500000000165411321531274015274 0ustar dapatrickdapatrick--- #YAML:1.0 name: XML-Stream version: 1.23 abstract: Creates an XML Stream connection and parses return data author: - Darian Anthony Patrick license: LGPL distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Authen::SASL: 0 Carp: 0 Encode: 0 FileHandle: 0 IO::Select: 0 IO::Socket: 0 MIME::Base64: 0 perl: 5.008 POSIX: 0 Sys::Hostname: 0 utf8: 0 resources: bugtracker: https://rt.cpan.org/Dist/Display.html?Queue=XML-Stream repository: http://github.com/dap/XML-Stream no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 XML-Stream-1.23/LICENSE.LGPL0000644000175000017500000006143711316467730015603 0ustar dapatrickdapatrick GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! XML-Stream-1.23/MANIFEST0000644000175000017500000000123511321531274015147 0ustar dapatrickdapatrickCHANGES INFO lib/XML/Stream.pm lib/XML/Stream/IO/Select/Win32.pm lib/XML/Stream/Namespace.pm lib/XML/Stream/Node.pm lib/XML/Stream/Parser.pm lib/XML/Stream/Parser/DTD.pm lib/XML/Stream/Tree.pm lib/XML/Stream/XPath.pm lib/XML/Stream/XPath/Op.pm lib/XML/Stream/XPath/Query.pm lib/XML/Stream/XPath/Value.pm LICENSE.LGPL Makefile.PL MANIFEST This list of files META.yml README t/0-signature.t t/buildxml.t t/cdata.t t/lib/Test/Builder.pm t/lib/Test/More.pm t/lib/Test/Simple.pm t/load.t t/parse_node.t t/parse_tree.t t/quotes.t t/tcpip.t t/tcpip2ssl.t t/test.xml t/xml2config.t t/xpath.t SIGNATURE Public-key signature (added by MakeMaker) XML-Stream-1.23/t/0000755000175000017500000000000011321531273014257 5ustar dapatrickdapatrickXML-Stream-1.23/t/tcpip.t0000644000175000017500000000124511316520062015563 0ustar dapatrickdapatrickuse lib "t/lib"; use Test::More tests=>4; BEGIN{ use_ok("XML::Stream","Node"); } my $stream = new XML::Stream(style=>"node"); ok( defined($stream), "new()" ); isa_ok( $stream, "XML::Stream" ); SKIP: { my $sock = IO::Socket::INET->new(PeerAddr=>'jabber.org:5222'); skip "Cannot open connection (maybe a firewall?)",1 unless defined($sock); my $status = $stream->Connect(hostname=>"jabber.org", port=>5222, namespace=>"jabber:client", connectiontype=>"tcpip", timeout=>10); ok( defined($status), "Made connection"); } XML-Stream-1.23/t/load.t0000644000175000017500000000016011316467730015372 0ustar dapatrickdapatrickBEGIN {print "1..1\n";} END {print "not ok 1\n" unless $loaded;} use XML::Stream; $loaded = 1; print "ok 1\n"; XML-Stream-1.23/t/xpath.t0000644000175000017500000001161311316467730015604 0ustar dapatrickdapatrickuse lib "t/lib"; use Test::More tests=>105; BEGIN{ use_ok("XML::Stream","Node","Tree"); } my @value; foreach my $type ("tree","node") { my $parser = new XML::Stream::Parser(style=>$type); isa_ok($parser,"XML::Stream::Parser"); $node = $parser->parsefile("t/test.xml"); isa_ok($node,"ARRAY") if ($type eq "tree"); isa_ok($node,"XML::Stream::Node") if ($type eq "node"); @value = &XML::Stream::XPath($node,'last/@test'); is( $#value, 0, "'last/\@test' - Only one match?"); is( $value[0], 5, "correct value?"); @value = &XML::Stream::XPath($node,'last/test1/test2/test3/text()'); is( $#value, 0, "'last/test1/test2/test3/text()' - Only one match?"); is( $value[0], "This is a test.", "correct value?"); @value = &XML::Stream::XPath($node,'last/test1/test2/test3'); is( $#value, 0, "'last/test1/test2/test3' - Only one match?"); is( &XML::Stream::GetXMLData("value",$value[0]), "This is a test.", "correct value?"); my %value = &XML::Stream::XPath($node,'foo/@*'); is( scalar(keys(%value)), 1, "'foo/\@\*' - Only one attribute?"); is( $value{test}, 3, "correct value?"); @value = &XML::Stream::XPath($node,'last//test3'); is( $#value, 0, "'last//test3' - Only one match?"); is( &XML::Stream::GetXMLData("value",$value[0]), "This is a test.", "correct value?"); @value = &XML::Stream::XPath($node,'a//e'); is( $#value, 2, "'a//e' - Only three matches?"); is( &XML::Stream::GetXMLData("tag",$value[0]), "e", "is it ?"); is( &XML::Stream::GetXMLData("value",$value[0],"e"), "foo1", "correct value?"); is( &XML::Stream::GetXMLData("tag",$value[1]), "e", "is it ?"); is( &XML::Stream::GetXMLData("value",$value[1]), "foo1", "correct value?"); is( &XML::Stream::GetXMLData("tag",$value[2]), "e", "is it ?"); is( &XML::Stream::GetXMLData("value",$value[2]), "foo2", "correct value?"); @value = &XML::Stream::XPath($node,'//e'); is( $#value, 3, "'//e' - Only four matches?"); is( &XML::Stream::GetXMLData("tag",$value[0]), "e", "is it ?"); is( &XML::Stream::GetXMLData("value",$value[0],"e"), "foo1", "correct value?"); is( &XML::Stream::GetXMLData("tag",$value[1]), "e", "is it ?"); is( &XML::Stream::GetXMLData("value",$value[1]), "foo1", "correct value?"); is( &XML::Stream::GetXMLData("tag",$value[2]), "e", "is it ?"); is( &XML::Stream::GetXMLData("value",$value[2]), "foo2", "correct value?"); is( &XML::Stream::GetXMLData("tag",$value[3]), "e", "is it ?"); is( &XML::Stream::GetXMLData("value",$value[3]), "bar", "correct value?"); @value = &XML::Stream::XPath($node,'a/b//d/e'); is( $#value, 1, "'a/b//d/e' - Only two matches?"); is( &XML::Stream::GetXMLData("tag",$value[0]), "e", "is it ?"); is( &XML::Stream::GetXMLData("value",$value[0],"e"), "foo1", "correct value?"); is( &XML::Stream::GetXMLData("tag",$value[1]), "e", "is it ?"); is( &XML::Stream::GetXMLData("value",$value[1]), "foo2", "correct value?"); @value = &XML::Stream::XPath($node,'library//chapter//para/@test'); is( $#value, 1, "'library//chapter//para/\@test' - Only two matches?"); is( $value[0], "b", "correct value?"); is( $value[1], "a", "correct value?"); @value = &XML::Stream::XPath($node,'filter[@id and @mytest="2"]/text()'); is( $#value, 0, "'filter[\@id and \@mytest=\"2\"]/text()' - Only one match?"); is( $value[0], "valueA", "correct value?"); @value = &XML::Stream::XPath($node,'newfilter[@bar and sub="foo1"]'); is( $#value, 0, "'newfilter[\@bar and sub=\"foo1\"]' - Only one match?"); is( &XML::Stream::GetXMLData("tag",$value[0]), "newfilter", "is it ?"); is( &XML::Stream::GetXMLData("value",$value[0],"sub"), "foo1", "correct value?"); @value = &XML::Stream::XPath($node,'startest/*[@test]'); is( $#value, 1, "'startest/*[\@test]' - Only two matches?"); is( &XML::Stream::GetXMLData("tag",$value[0]), "foo", "is the first one ?"); is( &XML::Stream::GetXMLData("tag",$value[1]), "bing", "is the second one ?"); @value = &XML::Stream::XPath($node,'startest/*[not(@test)]'); is( $#value, 0, "'startest/*[not(\@test)]' - Only one matches?"); is( &XML::Stream::GetXMLData("tag",$value[0]), "bar", "is it ?"); @value = &XML::Stream::XPath($node,'startest/*[name() != "foo"]'); is( $#value, 1, "'startest/*[name() != \"foo\"]' - Only two matches?"); is( &XML::Stream::GetXMLData("tag",$value[0]), "bar", "is it ?"); is( &XML::Stream::GetXMLData("tag",$value[1]), "bing", "is it ?"); @value = &XML::Stream::XPath($node,'//e[starts-with(text(),"foo")]'); is( $#value, 1, "'//e[starts-with(text(),\"foo\")]' - Only two matches?"); is( &XML::Stream::GetXMLData("value",$value[0]), "foo1", "correct value?"); is( &XML::Stream::GetXMLData("value",$value[1]), "foo2", "correct value?"); } XML-Stream-1.23/t/cdata.t0000644000175000017500000000117111317202201015507 0ustar dapatrickdapatrickuse lib './lib'; use Test::More tests => 5; use strict; BEGIN { use_ok('XML::Stream', 'Node'); } my $a = new XML::Stream::Node; $a->set_tag("body"); $a->add_cdata("one"); is ($a->GetXML(), q[one], 'cdata'); my $b = $a->copy; is ($b->GetXML(), q[one], 'copy cdata'); $a->add_child("a","two")->put_attrib(href=>"http://www.google.com"); $a->add_cdata("three"); is ($a->GetXML(), q[onetwothree], 'cdata/element/cdata'); my $c = $a->copy; is ($c->GetXML(), q[onetwothree], 'copy cdata/element/cdata'); XML-Stream-1.23/t/lib/0000755000175000017500000000000011321531273015025 5ustar dapatrickdapatrickXML-Stream-1.23/t/lib/Test/0000755000175000017500000000000011321531273015744 5ustar dapatrickdapatrickXML-Stream-1.23/t/lib/Test/More.pm0000644000175000017500000007467611316467730017242 0ustar dapatrickdapatrickpackage Test::More; use 5.004; use strict; use Test::Builder; # Can't use Carp because it might cause use_ok() to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my($file, $line) = (caller(1))[1,2]; warn @_, " at $file line $line\n"; } require Exporter; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); $VERSION = '0.47'; @ISA = qw(Exporter); @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan can_ok isa_ok diag ); my $Test = Test::Builder->new; # 5.004's Exporter doesn't have export_to_level. sub _export_to_level { my $pkg = shift; my $level = shift; (undef) = shift; # redundant arg my $callpkg = caller($level); $pkg->export($callpkg, @_); } =head1 NAME Test::More - yet another framework for writing test scripts =head1 SYNOPSIS use Test::More tests => $Num_Tests; # or use Test::More qw(no_plan); # or use Test::More skip_all => $reason; BEGIN { use_ok( 'Some::Module' ); } require_ok( 'Some::Module' ); # Various ways to say "ok" ok($this eq $that, $test_name); is ($this, $that, $test_name); isnt($this, $that, $test_name); # Rather than print STDERR "# here's what went wrong\n" diag("here's what went wrong"); like ($this, qr/that/, $test_name); unlike($this, qr/that/, $test_name); cmp_ok($this, '==', $that, $test_name); is_deeply($complex_structure1, $complex_structure2, $test_name); SKIP: { skip $why, $how_many unless $have_some_feature; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; TODO: { local $TODO = $why; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; can_ok($module, @methods); isa_ok($object, $class); pass($test_name); fail($test_name); # Utility comparison functions. eq_array(\@this, \@that); eq_hash(\%this, \%that); eq_set(\@this, \@that); # UNIMPLEMENTED!!! my @status = Test::More::status; # UNIMPLEMENTED!!! BAIL_OUT($why); =head1 DESCRIPTION B If you're just getting started writing tests, have a look at Test::Simple first. This is a drop in replacement for Test::Simple which you can switch to once you get the hang of basic testing. The purpose of this module is to provide a wide range of testing utilities. Various ways to say "ok" with better diagnostics, facilities to skip tests, test future features and compare complicated data structures. While you can do almost anything with a simple C function, it doesn't provide good diagnostic output. =head2 I love it when a plan comes together Before anything else, you need a testing plan. This basically declares how many tests your script is going to run to protect against premature failure. The preferred way to do this is to declare a plan when you C. use Test::More tests => $Num_Tests; There are rare cases when you will not know beforehand how many tests your script is going to run. In this case, you can declare that you have no plan. (Try to avoid using this as it weakens your test.) use Test::More qw(no_plan); In some cases, you'll want to completely skip an entire testing script. use Test::More skip_all => $skip_reason; Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L for details. If you want to control what functions Test::More will export, you have to use the 'import' option. For example, to import everything but 'fail', you'd do: use Test::More tests => 23, import => ['!fail']; Alternatively, you can use the plan() function. Useful for when you have to calculate the number of tests. use Test::More; plan tests => keys %Stuff * 3; or for deciding between running the tests at all: use Test::More; if( $^O eq 'MacOS' ) { plan skip_all => 'Test irrelevant on MacOS'; } else { plan tests => 42; } =cut sub plan { my(@plan) = @_; my $caller = caller; $Test->exported_to($caller); my @imports = (); foreach my $idx (0..$#plan) { if( $plan[$idx] eq 'import' ) { my($tag, $imports) = splice @plan, $idx, 2; @imports = @$imports; last; } } $Test->plan(@plan); __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); } sub import { my($class) = shift; goto &plan; } =head2 Test names By convention, each test is assigned a number in order. This is largely done automatically for you. However, it's often very useful to assign a name to each test. Which would you rather see: ok 4 not ok 5 ok 6 or ok 4 - basic multi-variable not ok 5 - simple exponential ok 6 - force == mass * acceleration The later gives you some idea of what failed. It also makes it easier to find the test in your script, simply search for "simple exponential". All test functions take a name argument. It's optional, but highly suggested that you use it. =head2 I'm ok, you're not ok. The basic purpose of this module is to print out either "ok #" or "not ok #" depending on if a given test succeeded or failed. Everything else is just gravy. All of the following print "ok" or "not ok" depending on if the test succeeded or failed. They all also return true or false, respectively. =over 4 =item B ok($this eq $that, $test_name); This simply evaluates any expression (C<$this eq $that> is just a simple example) and uses that to determine if the test succeeded or failed. A true expression passes, a false one fails. Very simple. For example: ok( $exp{9} == 81, 'simple exponential' ); ok( Film->can('db_Main'), 'set_db()' ); ok( $p->tests == 4, 'saw tests' ); ok( !grep !defined $_, @items, 'items populated' ); (Mnemonic: "This is ok.") $test_name is a very short description of the test that will be printed out. It makes it very easy to find a test in your script when it fails and gives others an idea of your intentions. $test_name is optional, but we B strongly encourage its use. Should an ok() fail, it will produce some diagnostics: not ok 18 - sufficient mucus # Failed test 18 (foo.t at line 42) This is actually Test::Simple's ok() routine. =cut sub ok ($;$) { my($test, $name) = @_; $Test->ok($test, $name); } =item B =item B is ( $this, $that, $test_name ); isnt( $this, $that, $test_name ); Similar to ok(), is() and isnt() compare their two arguments with C and C respectively and use the result of that to determine if the test succeeded or failed. So these: # Is the ultimate answer 42? is( ultimate_answer(), 42, "Meaning of Life" ); # $foo isn't empty isnt( $foo, '', "Got some foo" ); are similar to these: ok( ultimate_answer() eq 42, "Meaning of Life" ); ok( $foo ne '', "Got some foo" ); (Mnemonic: "This is that." "This isn't that.") So why use these? They produce better diagnostics on failure. ok() cannot know what you are testing for (beyond the name), but is() and isnt() know what the test was and why it failed. For example this test: my $foo = 'waffle'; my $bar = 'yarblokos'; is( $foo, $bar, 'Is foo the same as bar?' ); Will produce something like this: not ok 17 - Is foo the same as bar? # Failed test (foo.t at line 139) # got: 'waffle' # expected: 'yarblokos' So you can figure out what went wrong without rerunning the test. You are encouraged to use is() and isnt() over ok() where possible, however do not be tempted to use them to find out if something is true or false! # XXX BAD! $pope->isa('Catholic') eq 1 is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' ); This does not check if C<$pope->isa('Catholic')> is true, it checks if it returns 1. Very different. Similar caveats exist for false and 0. In these cases, use ok(). ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' ); For those grammatical pedants out there, there's an C function which is an alias of isnt(). =cut sub is ($$;$) { $Test->is_eq(@_); } sub isnt ($$;$) { $Test->isnt_eq(@_); } *isn't = \&isnt; =item B like( $this, qr/that/, $test_name ); Similar to ok(), like() matches $this against the regex C. So this: like($this, qr/that/, 'this is like that'); is similar to: ok( $this =~ /that/, 'this is like that'); (Mnemonic "This is like that".) The second argument is a regular expression. It may be given as a regex reference (i.e. C) or (for better compatibility with older perls) as a string that looks like a regex (alternative delimiters are currently not supported): like( $this, '/that/', 'this is like that' ); Regex options may be placed on the end (C<'/that/i'>). Its advantages over ok() are similar to that of is() and isnt(). Better diagnostics on failure. =cut sub like ($$;$) { $Test->like(@_); } =item B unlike( $this, qr/that/, $test_name ); Works exactly as like(), only it checks if $this B match the given pattern. =cut sub unlike { $Test->unlike(@_); } =item B cmp_ok( $this, $op, $that, $test_name ); Halfway between ok() and is() lies cmp_ok(). This allows you to compare two arguments using any binary perl operator. # ok( $this eq $that ); cmp_ok( $this, 'eq', $that, 'this eq that' ); # ok( $this == $that ); cmp_ok( $this, '==', $that, 'this == that' ); # ok( $this && $that ); cmp_ok( $this, '&&', $that, 'this || that' ); ...etc... Its advantage over ok() is when the test fails you'll know what $this and $that were: not ok 1 # Failed test (foo.t at line 12) # '23' # && # undef It's also useful in those cases where you are comparing numbers and is()'s use of C will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); =cut sub cmp_ok($$$;$) { $Test->cmp_ok(@_); } =item B can_ok($module, @methods); can_ok($object, @methods); Checks to make sure the $module or $object can do these @methods (works with functions, too). can_ok('Foo', qw(this that whatever)); is almost exactly like saying: ok( Foo->can('this') && Foo->can('that') && Foo->can('whatever') ); only without all the typing and with a better interface. Handy for quickly testing an interface. No matter how many @methods you check, a single can_ok() call counts as one test. If you desire otherwise, use: foreach my $meth (@methods) { can_ok('Foo', $meth); } =cut sub can_ok ($@) { my($proto, @methods) = @_; my $class = ref $proto || $proto; unless( @methods ) { my $ok = $Test->ok( 0, "$class->can(...)" ); $Test->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { local($!, $@); # don't interfere with caller's $@ # eval sometimes resets $! eval { $proto->can($method) } || push @nok, $method; } my $name; $name = @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)"; my $ok = $Test->ok( !@nok, $name ); $Test->diag(map " $class->can('$_') failed\n", @nok); return $ok; } =item B isa_ok($object, $class, $object_name); isa_ok($ref, $type, $ref_name); Checks to see if the given $object->isa($class). Also checks to make sure the object was defined in the first place. Handy for this sort of thing: my $obj = Some::Module->new; isa_ok( $obj, 'Some::Module' ); where you'd otherwise have to write my $obj = Some::Module->new; ok( defined $obj && $obj->isa('Some::Module') ); to safeguard against your test script blowing up. It works on references, too: isa_ok( $array_ref, 'ARRAY' ); The diagnostics of this test normally just refer to 'the object'. If you'd like them to be more specific, you can supply an $object_name (for example 'Test customer'). =cut sub isa_ok ($$;$) { my($object, $class, $obj_name) = @_; my $diag; $obj_name = 'The object' unless defined $obj_name; my $name = "$obj_name isa $class"; if( !defined $object ) { $diag = "$obj_name isn't defined"; } elsif( !ref $object ) { $diag = "$obj_name isn't a reference"; } else { # We can't use UNIVERSAL::isa because we want to honor isa() overrides local($@, $!); # eval sometimes resets $! my $rslt = eval { $object->isa($class) }; if( $@ ) { if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { if( !UNIVERSAL::isa($object, $class) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } else { die <isa on your object and got some weird error. This should never happen. Please contact the author immediately. Here's the error. $@ WHOA } } elsif( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } my $ok; if( $diag ) { $ok = $Test->ok( 0, $name ); $Test->diag(" $diag\n"); } else { $ok = $Test->ok( 1, $name ); } return $ok; } =item B =item B pass($test_name); fail($test_name); Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to wedge into an ok(). In this case, you can simply use pass() (to declare the test ok) or fail (for not ok). They are synonyms for ok(1) and ok(0). Use these very, very, very sparingly. =cut sub pass (;$) { $Test->ok(1, @_); } sub fail (;$) { $Test->ok(0, @_); } =back =head2 Diagnostics If you pick the right test function, you'll usually get a good idea of what went wrong when it failed. But sometimes it doesn't work out that way. So here we have ways for you to write your own diagnostic messages which are safer than just C. =over 4 =item B diag(@diagnostic_message); Prints a diagnostic message which is guaranteed not to interfere with test output. Handy for this sort of thing: ok( grep(/foo/, @users), "There's a foo user" ) or diag("Since there's no foo, check that /etc/bar is set up right"); which would produce: not ok 42 - There's a foo user # Failed test (foo.t at line 52) # Since there's no foo, check that /etc/bar is set up right. You might remember C with the mnemonic C. B The exact formatting of the diagnostic output is still changing, but it is guaranteed that whatever you throw at it it won't interfere with the test. =cut sub diag { $Test->diag(@_); } =back =head2 Module tests You usually want to test if the module you're testing loads ok, rather than just vomiting if its load fails. For such purposes we have C and C. =over 4 =item B BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } These simply use the given $module and test to make sure the load happened ok. It's recommended that you run use_ok() inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. If @imports are given, they are passed through to the use. So this: BEGIN { use_ok('Some::Module', qw(foo bar)) } is like doing this: use Some::Module qw(foo bar); don't try to do this: BEGIN { use_ok('Some::Module'); ...some code that depends on the use... ...happening at compile time... } instead, you want: BEGIN { use_ok('Some::Module') } BEGIN { ...some code that depends on the use... } =cut sub use_ok ($;@) { my($module, @imports) = @_; @imports = () unless @imports; my $pack = caller; local($@,$!); # eval sometimes interferes with $! eval <import(\@imports); USE my $ok = $Test->ok( !$@, "use $module;" ); unless( $ok ) { chomp $@; $Test->diag(< require_ok($module); Like use_ok(), except it requires the $module. =cut sub require_ok ($) { my($module) = shift; my $pack = caller; local($!, $@); # eval sometimes interferes with $! eval <ok( !$@, "require $module;" ); unless( $ok ) { chomp $@; $Test->diag(<. The way Test::More handles this is with a named block. Basically, a block of tests which can be skipped over or made todo. It's best if I just show you... =over 4 =item B SKIP: { skip $why, $how_many if $condition; ...normal testing code goes here... } This declares a block of tests that might be skipped, $how_many tests there are, $why and under what $condition to skip them. An example is the easiest way to illustrate: SKIP: { eval { require HTML::Lint }; skip "HTML::Lint not installed", 2 if $@; my $lint = new HTML::Lint; isa_ok( $lint, "HTML::Lint" ); $lint->parse( $html ); is( $lint->errors, 0, "No errors found in HTML" ); } If the user does not have HTML::Lint installed, the whole block of code I. Test::More will output special ok's which Test::Harness interprets as skipped, but passing, tests. It's important that $how_many accurately reflects the number of tests in the SKIP block so the # of tests run will match up with your plan. It's perfectly safe to nest SKIP blocks. Each SKIP block must have the label C, or Test::More can't work its magic. You don't skip tests which are failing because there's a bug in your program, or for which you don't yet have code written. For that you use TODO. Read on. =cut #'# sub skip { my($why, $how_many) = @_; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "skip() needs to know \$how_many tests are in the block" unless $Test::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { $Test->skip($why); } local $^W = 0; last SKIP; } =item B TODO: { local $TODO = $why if $condition; ...normal testing code goes here... } Declares a block of tests you expect to fail and $why. Perhaps it's because you haven't fixed a bug or haven't finished a new feature: TODO: { local $TODO = "URI::Geller not finished"; my $card = "Eight of clubs"; is( URI::Geller->your_card, $card, 'Is THIS your card?' ); my $spoon; URI::Geller->bend_spoon; is( $spoon, 'bent', "Spoon bending, that's original" ); } With a todo block, the tests inside are expected to fail. Test::More will run the tests normally, but print out special flags indicating they are "todo". Test::Harness will interpret failures as being ok. Should anything succeed, it will report it as an unexpected success. You then know the thing you had todo is done and can remove the TODO flag. The nice part about todo tests, as opposed to simply commenting out a block of tests, is it's like having a programmatic todo list. You know how much work is left to be done, you're aware of what bugs there are, and you'll know immediately when they're fixed. Once a todo test starts succeeding, simply move it outside the block. When the block is empty, delete it. =item B TODO: { todo_skip $why, $how_many if $condition; ...normal testing code... } With todo tests, it's best to have the tests actually run. That way you'll know when they start passing. Sometimes this isn't possible. Often a failing test will cause the whole program to die or hang, even inside an C with and using C. In these extreme cases you have no choice but to skip over the broken tests entirely. The syntax and behavior is similar to a C except the tests will be marked as failing but todo. Test::Harness will interpret them as passing. =cut sub todo_skip { my($why, $how_many) = @_; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $Test::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { $Test->todo_skip($why); } local $^W = 0; last TODO; } =item When do I use SKIP vs. TODO? B, use SKIP. This includes optional modules that aren't installed, running under an OS that doesn't have some feature (like fork() or symlinks), or maybe you need an Internet connection and one isn't available. B, use TODO. This is for any code you haven't written yet, or bugs you have yet to fix, but want to put tests in your testing script (always a good idea). =back =head2 Comparison functions Not everything is a simple eq check or regex. There are times you need to see if two arrays are equivalent, for instance. For these instances, Test::More provides a handful of useful functions. B These are NOT well-tested on circular references. Nor am I quite sure what will happen with filehandles. =over 4 =item B is_deeply( $this, $that, $test_name ); Similar to is(), except that if $this and $that are hash or array references, it does a deep comparison walking each data structure to see if they are equivalent. If the two structures are different, it will display the place where they start differing. Barrie Slaymaker's Test::Differences module provides more in-depth functionality along these lines, and it plays well with Test::More. B Display of scalar refs is not quite 100% =cut use vars qw(@Data_Stack); my $DNE = bless [], 'Does::Not::Exist'; sub is_deeply { my($this, $that, $name) = @_; my $ok; if( !ref $this || !ref $that ) { $ok = $Test->is_eq($this, $that, $name); } else { local @Data_Stack = (); if( _deep_check($this, $that) ) { $ok = $Test->ok(1, $name); } else { $ok = $Test->ok(0, $name); $ok = $Test->diag(_format_stack(@Data_Stack)); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{$Stack[-1]{vals}}[0,1]; my @vars = (); ($vars[0] = $var) =~ s/\$FOO/ \$got/; ($vars[1] = $var) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx (0..$#vals) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : $val eq $DNE ? "Does not exist" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } =item B eq_array(\@this, \@that); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. =cut #'# sub eq_array { my($a1, $a2) = @_; return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for (0..$max) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; $ok = _deep_check($e1,$e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _deep_check { my($e1, $e2) = @_; my $ok = 0; my $eq; { # Quiet uninitialized value warnings when comparing undefs. local $^W = 0; if( $e1 eq $e2 ) { $ok = 1; } else { if( UNIVERSAL::isa($e1, 'ARRAY') and UNIVERSAL::isa($e2, 'ARRAY') ) { $ok = eq_array($e1, $e2); } elsif( UNIVERSAL::isa($e1, 'HASH') and UNIVERSAL::isa($e2, 'HASH') ) { $ok = eq_hash($e1, $e2); } elsif( UNIVERSAL::isa($e1, 'REF') and UNIVERSAL::isa($e2, 'REF') ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } elsif( UNIVERSAL::isa($e1, 'SCALAR') and UNIVERSAL::isa($e2, 'SCALAR') ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); } else { push @Data_Stack, { vals => [$e1, $e2] }; $ok = 0; } } } return $ok; } =item B eq_hash(\%this, \%that); Determines if the two hashes contain the same keys and values. This is a deep check. =cut sub eq_hash { my($a1, $a2) = @_; return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k (keys %$bigger) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; $ok = _deep_check($e1, $e2); pop @Data_Stack if $ok; last unless $ok; } return $ok; } =item B eq_set(\@this, \@that); Similar to eq_array(), except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. B By historical accident, this is not a true set comparision. While the order of elements does not matter, duplicate elements do. =cut # We must make sure that references are treated neutrally. It really # doesn't matter how we sort them, as long as both arrays are sorted # with the same algorithm. sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b } sub eq_set { my($a1, $a2) = @_; return 0 unless @$a1 == @$a2; # There's faster ways to do this, but this is easiest. return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); } =back =head2 Extending and Embedding Test::More Sometimes the Test::More interface isn't quite enough. Fortunately, Test::More is built on top of Test::Builder which provides a single, unified backend for any test library to use. This means two test libraries which both use Test::Builder B. If you simply want to do a little tweaking of how the tests behave, you can access the underlying Test::Builder object like so: =over 4 =item B my $test_builder = Test::More->builder; Returns the Test::Builder object underlying Test::More for you to play with. =cut sub builder { return Test::Builder->new; } =back =head1 NOTES Test::More is B tested all the way back to perl 5.004. Test::More is thread-safe for perl 5.8.0 and up. =head1 BUGS and CAVEATS =over 4 =item Making your own ok() If you are trying to extend Test::More, don't. Use Test::Builder instead. =item The eq_* family has some caveats. =item Test::Harness upgrades no_plan and todo depend on new Test::Harness features and fixes. If you're going to distribute tests that use no_plan or todo your end-users will have to upgrade Test::Harness to the latest one on CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness will work fine. If you simply depend on Test::More, it's own dependencies will cause a Test::Harness upgrade. =back =head1 HISTORY This is a case of convergent evolution with Joshua Pritikin's Test module. I was largely unaware of its existence when I'd first written my own ok() routines. This module exists because I can't figure out how to easily wedge test names into Test's interface (along with a few other problems). The goal here is to have a testing utility that's simple to learn, quick to use and difficult to trip yourself up with while still providing more flexibility than the existing Test.pm. As such, the names of the most common routines are kept tiny, special cases and magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO L if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (it's forward compatible). L for more ways to test complex data structures. And it plays well with Test::More. L is the old testing module. Its main benefit is that it has been distributed with Perl since 5.004_05. L for details on how your test results are interpreted by Perl. L describes a very featureful unit testing interface. L shows the idea of embedded testing. L is another approach to embedded testing. =head1 AUTHORS Michael G Schwern Eschwern@pobox.comE with much inspiration from Joshua Pritikin's Test module and lots of help from Barrie Slaymaker, Tony Bowden, chromatic and the perl-qa gang. =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; XML-Stream-1.23/t/lib/Test/Simple.pm0000644000175000017500000001456511316467730017560 0ustar dapatrickdapatrickpackage Test::Simple; use 5.004; use strict 'vars'; use vars qw($VERSION); $VERSION = '0.47'; use Test::Builder; my $Test = Test::Builder->new; sub import { my $self = shift; my $caller = caller; *{$caller.'::ok'} = \&ok; $Test->exported_to($caller); $Test->plan(@_); } =head1 NAME Test::Simple - Basic utilities for writing tests. =head1 SYNOPSIS use Test::Simple tests => 1; ok( $foo eq $bar, 'foo is bar' ); =head1 DESCRIPTION ** If you are unfamiliar with testing B first! ** This is an extremely simple, extremely basic module for writing tests suitable for CPAN modules and other pursuits. If you wish to do more complicated testing, use the Test::More module (a drop-in replacement for this one). The basic unit of Perl testing is the ok. For each thing you want to test your program will print out an "ok" or "not ok" to indicate pass or fail. You do this with the ok() function (see below). The only other constraint is you must pre-declare how many tests you plan to run. This is in case something goes horribly wrong during the test and your test program aborts, or skips a test or whatever. You do this like so: use Test::Simple tests => 23; You must have a plan. =over 4 =item B ok( $foo eq $bar, $name ); ok( $foo eq $bar ); ok() is given an expression (in this case C<$foo eq $bar>). If it's true, the test passed. If it's false, it didn't. That's about it. ok() prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). # This produces "ok 1 - Hell not yet frozen over" (or not ok) ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand what your test is for. It's highly recommended you use test names. All tests are run in scalar context. So this: ok( @stuff, 'I have some stuff' ); will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { $Test->ok(@_); } =back Test::Simple will start by printing number of tests run in the form "1..M" (so "1..5" means you're going to run 5 tests). This strange format lets Test::Harness know how many tests you plan on running in case something goes horribly wrong. If all your tests passed, Test::Simple will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Simple will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. This module is by no means trying to be a complete testing system. It's just to get you started. Once you're off the ground its recommended you look at L. =head1 EXAMPLE Here's an example of a simple .t file for the fictional Film module. use Test::Simple tests => 5; use Film; # What you're testing. my $btaste = Film->new({ Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1 }); ok( defined($btaste) and ref $btaste eq 'Film', 'new() works' ); ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); ok( $btaste->Rating eq 'R', 'Rating() get' ); ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); It will produce output like this: 1..5 ok 1 - new() works ok 2 - Title() get ok 3 - Director() get not ok 4 - Rating() get # Failed test (t/film.t at line 14) ok 5 - NumExplodingSheep() get # Looks like you failed 1 tests of 5 Indicating the Film::Rating() method is broken. =head1 CAVEATS Test::Simple will only report a maximum of 254 failures in its exit code. If this is a problem, you probably have a huge test script. Split it into multiple files. (Otherwise blame the Unix folks for using an unsigned short integer as the exit status). Because VMS's exit codes are much, much different than the rest of the universe, and perl does horrible mangling to them that gets in my way, it works like this on VMS. 0 SS$_NORMAL all tests successful 4 SS$_ABORT something went wrong Unfortunately, I can't differentiate any further. =head1 NOTES Test::Simple is B tested all the way back to perl 5.004. Test::Simple is thread-safe in perl 5.8.0 and up. =head1 HISTORY This module was conceived while talking with Tony Bowden in his kitchen one night about the problems I was having writing some really complicated feature into the new Testing module. He observed that the main problem is not dealing with these edge cases but that people hate to write tests B. What was needed was a dead simple module that took all the hard work out of testing and was really, really easy to learn. Paul Johnson simultaneously had this idea (unfortunately, he wasn't in Tony's kitchen). This is it. =head1 SEE ALSO =over 4 =item L More testing functions! Once you outgrow Test::Simple, look at Test::More. Test::Simple is 100% forward compatible with Test::More (i.e. you can just use Test::More instead of Test::Simple in your programs and things will still work). =item L The original Perl testing module. =item L Elaborate unit testing. =item L, L Embed tests in your code! =item L Interprets the output of your test program. =back =head1 AUTHORS Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern Eschwern@pobox.comE, wardrobe by Calvin Klein. =head1 COPYRIGHT Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; XML-Stream-1.23/t/lib/Test/Builder.pm0000644000175000017500000007377311316467730017723 0ustar dapatrickdapatrickpackage Test::Builder; use 5.004; # $^C was only introduced in 5.005-ish. We do this to prevent # use of uninitialized value warnings in older perls. $^C ||= 0; use strict; use vars qw($VERSION $CLASS); $VERSION = '0.17'; $CLASS = __PACKAGE__; my $IsVMS = $^O eq 'VMS'; # Make Test::Builder thread-safe for ithreads. BEGIN { use Config; if( $] >= 5.008 && $Config{useithreads} ) { require threads; require threads::shared; threads::shared->import; } else { *share = sub { 0 }; *lock = sub { 0 }; } } use vars qw($Level); my($Test_Died) = 0; my($Have_Plan) = 0; my $Original_Pid = $$; my $Curr_Test = 0; share($Curr_Test); my @Test_Results = (); share(@Test_Results); my @Test_Details = (); share(@Test_Details); =head1 NAME Test::Builder - Backend for building test libraries =head1 SYNOPSIS package My::Test::Module; use Test::Builder; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(ok); my $Test = Test::Builder->new; $Test->output('my_logfile'); sub import { my($self) = shift; my $pack = caller; $Test->exported_to($pack); $Test->plan(@_); $self->export_to_level(1, $self, 'ok'); } sub ok { my($test, $name) = @_; $Test->ok($test, $name); } =head1 DESCRIPTION Test::Simple and Test::More have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides the a building block upon which to write your own test libraries I. =head2 Construction =over 4 =item B my $Test = Test::Builder->new; Returns a Test::Builder object representing the current state of the test. Since you only run one test per program, there is B Test::Builder object. No matter how many times you call new(), you're getting the same object. (This is called a singleton). =cut my $Test; sub new { my($class) = shift; $Test ||= bless ['Move along, nothing to see here'], $class; return $Test; } =back =head2 Setting up tests These methods are for setting up tests and declaring how many there are. You usually only want to call one of these methods. =over 4 =item B my $pack = $Test->exported_to; $Test->exported_to($pack); Tells Test::Builder what package you exported your functions to. This is important for getting TODO tests right. =cut my $Exported_To; sub exported_to { my($self, $pack) = @_; if( defined $pack ) { $Exported_To = $pack; } return $Exported_To; } =item B $Test->plan('no_plan'); $Test->plan( skip_all => $reason ); $Test->plan( tests => $num_tests ); A convenient way to set up your tests. Call this and Test::Builder will print the appropriate headers and take the appropriate actions. If you call plan(), don't call any of the other methods below. =cut sub plan { my($self, $cmd, $arg) = @_; return unless $cmd; if( $Have_Plan ) { die sprintf "You tried to plan twice! Second plan at %s line %d\n", ($self->caller)[1,2]; } if( $cmd eq 'no_plan' ) { $self->no_plan; } elsif( $cmd eq 'skip_all' ) { return $self->skip_all($arg); } elsif( $cmd eq 'tests' ) { if( $arg ) { return $self->expected_tests($arg); } elsif( !defined $arg ) { die "Got an undefined number of tests. Looks like you tried to ". "say how many tests you plan to run but made a mistake.\n"; } elsif( !$arg ) { die "You said to run 0 tests! You've got to run something.\n"; } } else { require Carp; my @args = grep { defined } ($cmd, $arg); Carp::croak("plan() doesn't understand @args"); } return 1; } =item B my $max = $Test->expected_tests; $Test->expected_tests($max); Gets/sets the # of tests we expect this test to run and prints out the appropriate headers. =cut my $Expected_Tests = 0; sub expected_tests { my($self, $max) = @_; if( defined $max ) { $Expected_Tests = $max; $Have_Plan = 1; $self->_print("1..$max\n") unless $self->no_header; } return $Expected_Tests; } =item B $Test->no_plan; Declares that this test will run an indeterminate # of tests. =cut my($No_Plan) = 0; sub no_plan { $No_Plan = 1; $Have_Plan = 1; } =item B $plan = $Test->has_plan Find out whether a plan has been defined. $plan is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). =cut sub has_plan { return($Expected_Tests) if $Expected_Tests; return('no_plan') if $No_Plan; return(undef); }; =item B $Test->skip_all; $Test->skip_all($reason); Skips all the tests, using the given $reason. Exits immediately with 0. =cut my $Skip_All = 0; sub skip_all { my($self, $reason) = @_; my $out = "1..0"; $out .= " # Skip $reason" if $reason; $out .= "\n"; $Skip_All = 1; $self->_print($out) unless $self->no_header; exit(0); } =back =head2 Running tests These actually run the tests, analogous to the functions in Test::More. $name is always optional. =over 4 =item B $Test->ok($test, $name); Your basic test. Pass if $test is true, fail if $test is false. Just like Test::Simple's ok(). =cut sub ok { my($self, $test, $name) = @_; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run a test without a plan! Gotta have a plan."); } lock $Curr_Test; $Curr_Test++; $self->diag(<caller; my $todo = $self->todo($pack); my $out; my $result = {}; share($result); unless( $test ) { $out .= "not "; @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); } $out .= "ok"; $out .= " $Curr_Test" if $self->use_numbers; if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $out .= " - $name"; $result->{name} = $name; } else { $result->{name} = ''; } if( $todo ) { my $what_todo = $todo; $out .= " # TODO $what_todo"; $result->{reason} = $what_todo; $result->{type} = 'todo'; } else { $result->{reason} = ''; $result->{type} = ''; } $Test_Results[$Curr_Test-1] = $result; $out .= "\n"; $self->_print($out); unless( $test ) { my $msg = $todo ? "Failed (TODO)" : "Failed"; $self->diag(" $msg test ($file at line $line)\n"); } return $test ? 1 : 0; } =item B $Test->is_eq($got, $expected, $name); Like Test::More's is(). Checks if $got eq $expected. This is the string version. =item B $Test->is_num($got, $expected, $name); Like Test::More's is(). Checks if $got == $expected. This is the numeric version. =cut sub is_eq { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok($test, $name); $self->_is_diag($got, 'eq', $expect) unless $test; return $test; } return $self->cmp_ok($got, 'eq', $expect, $name); } sub is_num { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok($test, $name); $self->_is_diag($got, '==', $expect) unless $test; return $test; } return $self->cmp_ok($got, '==', $expect, $name); } sub _is_diag { my($self, $got, $type, $expect) = @_; foreach my $val (\$got, \$expect) { if( defined $$val ) { if( $type eq 'eq' ) { # quote and force string context $$val = "'$$val'" } else { # force numeric context $$val = $$val+0; } } else { $$val = 'undef'; } } return $self->diag(sprintf < $Test->isnt_eq($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the string version. =item B $Test->is_num($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the numeric version. =cut sub isnt_eq { my($self, $got, $dont_expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok($test, $name); $self->_cmp_diag('ne', $got, $dont_expect) unless $test; return $test; } return $self->cmp_ok($got, 'ne', $dont_expect, $name); } sub isnt_num { my($self, $got, $dont_expect, $name) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok($test, $name); $self->_cmp_diag('!=', $got, $dont_expect) unless $test; return $test; } return $self->cmp_ok($got, '!=', $dont_expect, $name); } =item B $Test->like($this, qr/$regex/, $name); $Test->like($this, '/$regex/', $name); Like Test::More's like(). Checks if $this matches the given $regex. You'll want to avoid qr// if you want your tests to work before 5.005. =item B $Test->unlike($this, qr/$regex/, $name); $Test->unlike($this, '/$regex/', $name); Like Test::More's unlike(). Checks if $this B the given $regex. =cut sub like { my($self, $this, $regex, $name) = @_; local $Level = $Level + 1; $self->_regex_ok($this, $regex, '=~', $name); } sub unlike { my($self, $this, $regex, $name) = @_; local $Level = $Level + 1; $self->_regex_ok($this, $regex, '!~', $name); } =item B $Test->maybe_regex(qr/$regex/); $Test->maybe_regex('/$regex/'); Convenience method for building testing functions that take regular expressions as arguments, but need to work before perl 5.005. Takes a quoted regular expression produced by qr//, or a string representing a regular expression. Returns a Perl value which may be used instead of the corresponding regular expression, or undef if it's argument is not recognised. For example, a version of like(), sans the useful diagnostic messages, could be written as: sub laconic_like { my ($self, $this, $regex, $name) = @_; my $usable_regex = $self->maybe_regex($regex); die "expecting regex, found '$regex'\n" unless $usable_regex; $self->ok($this =~ m/$usable_regex/, $name); } =cut sub maybe_regex { my ($self, $regex) = @_; my $usable_regex = undef; if( ref $regex eq 'Regexp' ) { $usable_regex = $regex; } # Check if it looks like '/foo/' elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { $usable_regex = length $opts ? "(?$opts)$re" : $re; }; return($usable_regex) }; sub _regex_ok { my($self, $this, $regex, $cmp, $name) = @_; local $Level = $Level + 1; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless (defined $usable_regex) { $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { local $^W = 0; my $test = $this =~ /$usable_regex/ ? 1 : 0; $test = !$test if $cmp eq '!~'; $ok = $self->ok( $test, $name ); } unless( $ok ) { $this = defined $this ? "'$this'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; $self->diag(sprintf < $Test->cmp_ok($this, $type, $that, $name); Works just like Test::More's cmp_ok(). $Test->cmp_ok($big_num, '!=', $other_big_num); =cut sub cmp_ok { my($self, $got, $type, $expect, $name) = @_; my $test; { local $^W = 0; local($@,$!); # don't interfere with $@ # eval() sometimes resets $! $test = eval "\$got $type \$expect"; } local $Level = $Level + 1; my $ok = $self->ok($test, $name); unless( $ok ) { if( $type =~ /^(eq|==)$/ ) { $self->_is_diag($got, $type, $expect); } else { $self->_cmp_diag($got, $type, $expect); } } return $ok; } sub _cmp_diag { my($self, $got, $type, $expect) = @_; $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; return $self->diag(sprintf < $Test->BAILOUT($reason); Indicates to the Test::Harness that things are going so badly all testing should terminate. This includes running any additional test scripts. It will exit with 255. =cut sub BAILOUT { my($self, $reason) = @_; $self->_print("Bail out! $reason"); exit 255; } =item B $Test->skip; $Test->skip($why); Skips the current test, reporting $why. =cut sub skip { my($self, $why) = @_; $why ||= ''; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => $why, ); $Test_Results[$Curr_Test-1] = \%result; my $out = "ok"; $out .= " $Curr_Test" if $self->use_numbers; $out .= " # skip $why\n"; $Test->_print($out); return 1; } =item B $Test->todo_skip; $Test->todo_skip($why); Like skip(), only it will declare the test as failing and TODO. Similar to print "not ok $tnum # TODO $why\n"; =cut sub todo_skip { my($self, $why) = @_; $why ||= ''; unless( $Have_Plan ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, ); $Test_Results[$Curr_Test-1] = \%result; my $out = "not ok"; $out .= " $Curr_Test" if $self->use_numbers; $out .= " # TODO & SKIP $why\n"; $Test->_print($out); return 1; } =begin _unimplemented =item B $Test->skip_rest; $Test->skip_rest($reason); Like skip(), only it skips all the rest of the tests you plan to run and terminates the test. If you're running under no_plan, it skips once and terminates the test. =end _unimplemented =back =head2 Test style =over 4 =item B $Test->level($how_high); How far up the call stack should $Test look when reporting where the test failed. Defaults to 1. Setting $Test::Builder::Level overrides. This is typically useful localized: { local $Test::Builder::Level = 2; $Test->ok($test); } =cut sub level { my($self, $level) = @_; if( defined $level ) { $Level = $level; } return $Level; } $CLASS->level(1); =item B $Test->use_numbers($on_or_off); Whether or not the test should output numbers. That is, this if true: ok 1 ok 2 ok 3 or this if false ok ok ok Most useful when you can't depend on the test output order, such as when threads or forking is involved. Test::Harness will accept either, but avoid mixing the two styles. Defaults to on. =cut my $Use_Nums = 1; sub use_numbers { my($self, $use_nums) = @_; if( defined $use_nums ) { $Use_Nums = $use_nums; } return $Use_Nums; } =item B $Test->no_header($no_header); If set to true, no "1..N" header will be printed. =item B $Test->no_ending($no_ending); Normally, Test::Builder does some extra diagnostics when the test ends. It also changes the exit code as described in Test::Simple. If this is true, none of that will be done. =cut my($No_Header, $No_Ending) = (0,0); sub no_header { my($self, $no_header) = @_; if( defined $no_header ) { $No_Header = $no_header; } return $No_Header; } sub no_ending { my($self, $no_ending) = @_; if( defined $no_ending ) { $No_Ending = $no_ending; } return $No_Ending; } =back =head2 Output Controlling where the test output goes. It's ok for your test to change where STDOUT and STDERR point to, Test::Builder's default output settings will not be affected. =over 4 =item B $Test->diag(@msgs); Prints out the given $message. Normally, it uses the failure_output() handle, but if this is for a TODO test, the todo_output() handle is used. Output will be indented and marked with a # so as not to interfere with test output. A newline will be put on the end if there isn't one already. We encourage using this rather than calling print directly. Returns false. Why? Because diag() is often used in conjunction with a failing test (C) it "passes through" the failure. return ok(...) || diag(...); =for blame transfer Mark Fowler =cut sub diag { my($self, @msgs) = @_; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; # Escape each line with a #. foreach (@msgs) { $_ = 'undef' unless defined; s/^/# /gms; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; local $Level = $Level + 1; my $fh = $self->todo ? $self->todo_output : $self->failure_output; local($\, $", $,) = (undef, ' ', ''); print $fh @msgs; return 0; } =begin _private =item B<_print> $Test->_print(@msgs); Prints to the output() filehandle. =end _private =cut sub _print { my($self, @msgs) = @_; # Prevent printing headers when only compiling. Mostly for when # tests are deparsed with B::Deparse return if $^C; local($\, $", $,) = (undef, ' ', ''); my $fh = $self->output; # Escape each line after the first with a # so we don't # confuse Test::Harness. foreach (@msgs) { s/\n(.)/\n# $1/sg; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; print $fh @msgs; } =item B $Test->output($fh); $Test->output($file); Where normal "ok/not ok" test output should go. Defaults to STDOUT. =item B $Test->failure_output($fh); $Test->failure_output($file); Where diagnostic output on test failures and diag() should go. Defaults to STDERR. =item B $Test->todo_output($fh); $Test->todo_output($file); Where diagnostics about todo test failures and diag() should go. Defaults to STDOUT. =cut my($Out_FH, $Fail_FH, $Todo_FH); sub output { my($self, $fh) = @_; if( defined $fh ) { $Out_FH = _new_fh($fh); } return $Out_FH; } sub failure_output { my($self, $fh) = @_; if( defined $fh ) { $Fail_FH = _new_fh($fh); } return $Fail_FH; } sub todo_output { my($self, $fh) = @_; if( defined $fh ) { $Todo_FH = _new_fh($fh); } return $Todo_FH; } sub _new_fh { my($file_or_fh) = shift; my $fh; unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { $fh = do { local *FH }; open $fh, ">$file_or_fh" or die "Can't open test output log $file_or_fh: $!"; } else { $fh = $file_or_fh; } return $fh; } unless( $^C ) { # We dup STDOUT and STDERR so people can change them in their # test suites while still getting normal test output. open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. _autoflush(\*TESTOUT); _autoflush(\*STDOUT); _autoflush(\*TESTERR); _autoflush(\*STDERR); $CLASS->output(\*TESTOUT); $CLASS->failure_output(\*TESTERR); $CLASS->todo_output(\*TESTOUT); } sub _autoflush { my($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; } =back =head2 Test Status and Info =over 4 =item B my $curr_test = $Test->current_test; $Test->current_test($num); Gets/sets the current test # we're on. You usually shouldn't have to set this. =cut sub current_test { my($self, $num) = @_; lock($Curr_Test); if( defined $num ) { unless( $Have_Plan ) { require Carp; Carp::croak("Can't change the current test number without a plan!"); } $Curr_Test = $num; if( $num > @Test_Results ) { my $start = @Test_Results ? $#Test_Results + 1 : 0; for ($start..$num-1) { my %result; share(%result); %result = ( ok => 1, actual_ok => undef, reason => 'incrementing test number', type => 'unknown', name => undef ); $Test_Results[$_] = \%result; } } } return $Curr_Test; } =item B my @tests = $Test->summary; A simple summary of the tests so far. True for pass, false for fail. This is a logical pass/fail, so todos are passes. Of course, test #1 is $tests[0], etc... =cut sub summary { my($self) = shift; return map { $_->{'ok'} } @Test_Results; } =item B
my @tests = $Test->details; Like summary(), but with a lot more detail. $tests[$test_num - 1] = { 'ok' => is the test considered a pass? actual_ok => did it literally say 'ok'? name => name of the test (if any) type => type of test (if any, see below). reason => reason for the above (if any) }; 'ok' is true if Test::Harness will consider the test to be a pass. 'actual_ok' is a reflection of whether or not the test literally printed 'ok' or 'not ok'. This is for examining the result of 'todo' tests. 'name' is the name of the test. 'type' indicates if it was a special test. Normal tests have a type of ''. Type can be one of the following: skip see skip() todo see todo() todo_skip see todo_skip() unknown see below Sometimes the Test::Builder test counter is incremented without it printing any test output, for example, when current_test() is changed. In these cases, Test::Builder doesn't know the result of the test, so it's type is 'unkown'. These details for these tests are filled in. They are considered ok, but the name and actual_ok is left undef. For example "not ok 23 - hole count # TODO insufficient donuts" would result in this structure: $tests[22] = # 23 - 1, since arrays start from 0. { ok => 1, # logically, the test passed since it's todo actual_ok => 0, # in absolute terms, it failed name => 'hole count', type => 'todo', reason => 'insufficient donuts' }; =cut sub details { return @Test_Results; } =item B my $todo_reason = $Test->todo; my $todo_reason = $Test->todo($pack); todo() looks for a $TODO variable in your tests. If set, all tests will be considered 'todo' (see Test::More and Test::Harness for details). Returns the reason (ie. the value of $TODO) if running as todo tests, false otherwise. todo() is pretty part about finding the right package to look for $TODO in. It uses the exported_to() package to find it. If that's not set, it's pretty good at guessing the right package to look at. Sometimes there is some confusion about where todo() should be looking for the $TODO variable. If you want to be sure, tell it explicitly what $pack to use. =cut sub todo { my($self, $pack) = @_; $pack = $pack || $self->exported_to || $self->caller(1); no strict 'refs'; return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} : 0; } =item B my $package = $Test->caller; my($pack, $file, $line) = $Test->caller; my($pack, $file, $line) = $Test->caller($height); Like the normal caller(), except it reports according to your level(). =cut sub caller { my($self, $height) = @_; $height ||= 0; my @caller = CORE::caller($self->level + $height + 1); return wantarray ? @caller : $caller[0]; } =back =cut =begin _private =over 4 =item B<_sanity_check> _sanity_check(); Runs a bunch of end of test sanity checks to make sure reality came through ok. If anything is wrong it will die with a fairly friendly error message. =cut #'# sub _sanity_check { _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); _whoa(!$Have_Plan and $Curr_Test, 'Somehow your tests ran without a plan!'); _whoa($Curr_Test != @Test_Results, 'Somehow you got a different number of results than tests ran!'); } =item B<_whoa> _whoa($check, $description); A sanity check, similar to assert(). If the $check is true, something has gone horribly wrong. It will die with the given $description and a note to contact the author. =cut sub _whoa { my($check, $desc) = @_; if( $check ) { die < _my_exit($exit_num); Perl seems to have some trouble with exiting inside an END block. 5.005_03 and 5.6.1 both seem to do odd things. Instead, this function edits $? directly. It should ONLY be called from inside an END block. It doesn't actually exit, that's your job. =cut sub _my_exit { $? = $_[0]; return 1; } =back =end _private =cut $SIG{__DIE__} = sub { # We don't want to muck with death in an eval, but $^S isn't # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing # with it. Instead, we use caller. This also means it runs under # 5.004! my $in_eval = 0; for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { $in_eval = 1 if $sub =~ /^\(eval\)/; } $Test_Died = 1 unless $in_eval; }; sub _ending { my $self = shift; _sanity_check(); # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. do{ _my_exit($?) && return } if $Original_Pid != $$; # Bailout if plan() was never called. This is so # "require Test::Simple" doesn't puke. do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; # Figure out if we passed or failed and print helpful messages. if( @Test_Results ) { # The plan? We have no plan. if( $No_Plan ) { $self->_print("1..$Curr_Test\n") unless $self->no_header; $Expected_Tests = $Curr_Test; } # 5.8.0 threads bug. Shared arrays will not be auto-extended # by a slice. Worse, we have to fill in every entry else # we'll get an "Invalid value for shared scalar" error for my $idx ($#Test_Results..$Expected_Tests-1) { my %empty_result = (); share(%empty_result); $Test_Results[$idx] = \%empty_result unless defined $Test_Results[$idx]; } my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; $num_failed += abs($Expected_Tests - @Test_Results); if( $Curr_Test < $Expected_Tests ) { $self->diag(<<"FAIL"); Looks like you planned $Expected_Tests tests but only ran $Curr_Test. FAIL } elsif( $Curr_Test > $Expected_Tests ) { my $num_extra = $Curr_Test - $Expected_Tests; $self->diag(<<"FAIL"); Looks like you planned $Expected_Tests tests but ran $num_extra extra. FAIL } elsif ( $num_failed ) { $self->diag(<<"FAIL"); Looks like you failed $num_failed tests of $Expected_Tests. FAIL } if( $Test_Died ) { $self->diag(<<"FAIL"); Looks like your test died just after $Curr_Test. FAIL _my_exit( 255 ) && return; } _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; } elsif ( $Skip_All ) { _my_exit( 0 ) && return; } elsif ( $Test_Died ) { $self->diag(<<'FAIL'); Looks like your test died before it could output anything. FAIL } else { $self->diag("No tests run!\n"); _my_exit( 255 ) && return; } } END { $Test->_ending if defined $Test and !$Test->no_ending; } =head1 THREADS In perl 5.8.0 and later, Test::Builder is thread-safe. The test number is shared amongst all threads. This means if one thread sets the test number using current_test() they will all be effected. =head1 EXAMPLES CPAN can provide the best examples. Test::Simple, Test::More, Test::Exception and Test::Differences all use Test::Builder. =head1 SEE ALSO Test::Simple, Test::More, Test::Harness =head1 AUTHORS Original code by chromatic, maintained by Michael G Schwern Eschwern@pobox.comE =head1 COPYRIGHT Copyright 2002 by chromatic Echromatic@wgz.orgE, Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut 1; XML-Stream-1.23/t/test.xml0000644000175000017500000000352311316467730015775 0ustar dapatrickdapatrick This is a test. foo1 foo2 bar
pA
p1p2
p7p8
p13p14
p19p20
valueA valueB valueC foo1 foo2
foo3
foo4 foo5
foo6
embedded it.]]>
XML-Stream-1.23/t/parse_tree.t0000644000175000017500000000177511316467730016621 0ustar dapatrickdapatrickBEGIN {print "1..5\n";} END {print "not ok 1\n" unless $loaded;} use XML::Stream qw( Tree ); $loaded = 1; print "ok 1\n"; my @tests; $tests[4] = 1; my $stream = new XML::Stream(style=>"tree"); $stream->SetCallBacks(node=>sub{ &onPacket(@_) }); my $sid = $stream->OpenFile("t/test.xml"); my %status; while( %status = $stream->Process()) { last if ($status{$sid} == -1); } foreach (2..5) { print "not " unless $tests[$_]; print "ok $_\n"; } sub onPacket { my $sid = shift; my $packet = shift; return unless exists($packet->[1]->[0]->{test}); if ($packet->[1]->[0]->{test} eq "2") { $tests[2] = 1; } if ($packet->[1]->[0]->{test} eq "3") { if (defined($packet->[1]->[3]) && ($packet->[1]->[3] eq "bar")) { $tests[3] = 1; } } if ($packet->[1]->[0]->{test} eq "4") { $tests[4] = 0; } if ($packet->[1]->[0]->{test} eq "5") { if (defined($packet->[1]->[4]->[4]->[4]->[2]) && ($packet->[1]->[4]->[4]->[4]->[2] eq "This is a test.")) { $tests[5] = 1; } } } XML-Stream-1.23/t/parse_node.t0000644000175000017500000000246711316467730016606 0ustar dapatrickdapatrickBEGIN {print "1..7\n";} END {print "not ok 1\n" unless $loaded;} use XML::Stream qw( Node ); $loaded = 1; print "ok 1\n"; my @tests; $tests[4] = 1; my $stream = new XML::Stream( #debug=>"stdout",debuglevel=>99, style=>"node"); $stream->SetCallBacks(node=>sub{ &onPacket(@_) }); my $sid = $stream->OpenFile("t/test.xml"); my %status; while( %status = $stream->Process()) { last if ($status{$sid} == -1); } foreach (2..6) { print "not " unless $tests[$_]; print "ok $_\n"; } sub onPacket { my $sid = shift; my ($packet) = @_; return unless $packet->get_attrib("test"); if ($packet->get_attrib("test") eq "2") { $tests[2] = 1; } if ($packet->get_attrib("test") eq "3") { if (($packet->children())[1]->get_tag() eq "bar") { $tests[3] = 1; } } if ($packet->get_attrib("test") eq "4") { $tests[4] = 0; } if ($packet->get_attrib("test") eq "5") { if (((($packet->children())[1]->children())[1]->children())[1]->get_cdata() eq "This is a test.") { $tests[5] = 1; } } if ($packet->get_attrib("test") eq "6") { if ($packet->get_cdata() eq "This is cdata with embedded it.") { $tests[6] = 1; } } } my $node = new XML::Stream::Node("test",""); print "not " unless ($node->GetXML() eq "<foo/>"); print "ok 7\n"; XML-Stream-1.23/t/quotes.t0000644000175000017500000000214711317213750015772 0ustar dapatrickdapatrickuse lib './lib'; use Test::More tests => 3; use strict; # Test for RT#17325 BEGIN { use_ok('XML::Stream', 'Parser'); } my @test_strings = ( { xml => q[awayAway], message => 'one double quote', }, { xml => q[awayAway], message => 'one single quote', } ); foreach my $test_string ( @test_strings ) { my $p = XML::Stream::Parser->new(); my $return; my $message = $test_string->{'message'}; # The nature of the bug which this test aims to prove is such that an # infinite loop is caused on failure, hence this timeout code eval { local $SIG{ALRM} = sub { die "TIMED OUT\n" }; alarm 3; $return = $p->parse( $test_string->{'xml'} ); } or do { $return = ''; $message .= ' - ' . $@; }; isa_ok ( $return, 'ARRAY', $message ); } XML-Stream-1.23/t/buildxml.t0000644000175000017500000000657311316467730016311 0ustar dapatrickdapatrickuse lib "./lib"; use Test::More tests=>56; BEGIN{ use_ok( "XML::Stream","Tree", "Node" ); } my $packetIndex; my @packets; $packets[0] = ""; $packets[1] = " "; $packets[2] = " This is a test. "; $packets[3] = " foo1 foo2 "; $packets[4] = "bar"; $packets[5] = "
pA
p1p2
p7p8
p13p14
p19p20
"; $packets[6] = "valueA"; $packets[7] = "valueB"; $packets[8] = "valueC"; $packets[9] = "foo1"; $packets[10] = "foo2"; $packets[11] = "
foo3
"; $packets[12] = "foo4"; $packets[13] = "foo5"; $packets[14] = "
foo6
"; $packets[15] = " "; $packets[16] = "This is cdata with <tags/> embedded <in>it</in>."; foreach my $xmlType ("tree","node") { $packetIndex = 0; my $stream = new XML::Stream(style=>$xmlType); ok( defined($stream), "new() - $xmlType" ); isa_ok( $stream, "XML::Stream" ); $stream->SetCallBacks(node=>sub{ &onPacket($xmlType,@_) }); my $sid = $stream->OpenFile("t/test.xml"); my %status; while( %status = $stream->Process()) { last if ($status{$sid} == -1); } } sub onPacket { my $xmlType = shift; my $sid = shift; if ($xmlType eq "tree") { my $tree = shift; my $test = &XML::Stream::BuildXML($tree,""); $test =~ s/\r//g; is( $test, $packets[$packetIndex], "packet[$packetIndex]" ); } if ($xmlType eq "node") { my $node = shift; my $test = &XML::Stream::BuildXML($node,""); $test =~ s/\r//g; is( $test, $packets[$packetIndex], "packet[$packetIndex]" ); $node->add_raw_xml(""); $test = &XML::Stream::BuildXML($node); $test =~ s/\r//g; is( $test, $packets[$packetIndex], "packet[$packetIndex]" ); } $packetIndex++; } XML-Stream-1.23/t/0-signature.t0000644000175000017500000000170511301037154016602 0ustar dapatrickdapatrick#!/usr/bin/perl use strict; use Test::More; if (!$ENV{TEST_SIGNATURE}) { plan skip_all => "Set the environment variable TEST_SIGNATURE to enable this test."; } elsif (!eval { require Module::Signature; 1 }) { plan skip_all => "Next time around, consider installing Module::Signature, ". "so you can verify the integrity of this distribution."; } elsif ( !-e 'SIGNATURE' ) { plan skip_all => "SIGNATURE not found"; } elsif ( -s 'SIGNATURE' == 0 ) { plan skip_all => "SIGNATURE file empty"; } elsif (!eval { require Socket; Socket::inet_aton('pgp.mit.edu') }) { plan skip_all => "Cannot connect to the keyserver to check module ". "signature"; } else { plan tests => 1; } my $ret = Module::Signature::verify(); SKIP: { skip "Module::Signature cannot verify", 1 if $ret eq Module::Signature::CANNOT_VERIFY(); cmp_ok $ret, '==', Module::Signature::SIGNATURE_OK(), "Valid signature"; } XML-Stream-1.23/t/tcpip2ssl.t0000644000175000017500000000136511316500054016371 0ustar dapatrickdapatrick use lib "t/lib"; use Test::More tests=>3; SKIP: { eval("use IO::Socket::SSL 0.81;"); skip "IO::Socket::SSL not installed", 2 if $@; BEGIN{ use_ok( "XML::Stream","Tree", "Node" ); } my $stream = new XML::Stream(style=>"node"); ok( defined($stream), "new()" ); SKIP: { my $status = $stream->Connect(hostname=>"jabber.org", port=>5223, namespace=>"jabber:client", connectiontype=>"tcpip", ssl=>1, timeout=>10); skip "Cannot create initial socket", 1 unless $stream; ok( $stream, "converted" ); } } XML-Stream-1.23/t/xml2config.t0000644000175000017500000000266211316467730016534 0ustar dapatrickdapatrickBEGIN {print "1..9\n";} END {print "not ok 1\n" unless $loaded;} use XML::Stream qw( Tree Node ); $loaded = 1; print "ok 1\n"; my @tests; $tests[4] = 1; $tests[8] = 1; my $parser_tree = new XML::Stream::Parser(style=>"tree"); my $tree = $parser_tree->parsefile("t/test.xml"); %config = %{&XML::Stream::XML2Config($tree)}; if (exists($config{blah})) { my @keys = keys(%{$config{blah}}); if ($#keys == -1) { $tests[2] = 1; } } if (exists($config{foo}->{bar})) { my @keys = keys(%{$config{foo}->{bar}}); if ($#keys == -1) { $tests[3] = 1; } } if (exists($config{comment_test})) { $tests[4] = 0; } if (exists($config{last}->{test1}->{test2}->{test3})) { if ($config{last}->{test1}->{test2}->{test3} eq "This is a test.") { $tests[5] = 1; } } my $parser_node = new XML::Stream::Parser(style=>"node"); my $node = $parser_node->parsefile("t/test.xml"); %config = %{&XML::Stream::XML2Config($node)}; if (exists($config{blah})) { my @keys = keys(%{$config{blah}}); if ($#keys == -1) { $tests[6] = 1; } } if (exists($config{foo}->{bar})) { my @keys = keys(%{$config{foo}->{bar}}); if ($#keys == -1) { $tests[7] = 1; } } if (exists($config{comment_test})) { $tests[8] = 0; } if (exists($config{last}->{test1}->{test2}->{test3})) { if ($config{last}->{test1}->{test2}->{test3} eq "This is a test.") { $tests[9] = 1; } } foreach (2..9) { print "not " unless $tests[$_]; print "ok $_\n"; }