1############################################################################## 2# 3# This library is free software; you can redistribute it and/or 4# modify it under the terms of the GNU Library General Public 5# License as published by the Free Software Foundation; either 6# version 2 of the License, or (at your option) any later version. 7# 8# This library is distributed in the hope that it will be useful, 9# but WITHOUT ANY WARRANTY; without even the implied warranty of 10# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 11# Library General Public License for more details. 12# 13# You should have received a copy of the GNU Library General Public 14# License along with this library; if not, write to the 15# Free Software Foundation, Inc., 59 Temple Place - Suite 330, 16# Boston, MA 02111-1307, USA. 17# 18# Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ 19# 20############################################################################## 21 22package Net::XMPP::Protocol; 23 24=head1 NAME 25 26Net::XMPP::Protocol - XMPP Protocol Module 27 28=head1 SYNOPSIS 29 30Net::XMPP::Protocol is a module that provides a developer easy 31access to the XMPP Instant Messaging protocol. It provides high 32level functions to the Net::XMPP Client object. These functions are 33inherited by that modules. 34 35=head1 DESCRIPTION 36 37Protocol.pm seeks to provide enough high level APIs and automation of 38the low level APIs that writing a XMPP Client in Perl is trivial. For 39those that wish to work with the low level you can do that too, but 40those functions are covered in the documentation for each module. 41 42Net::XMPP::Protocol provides functions to login, send and receive 43messages, set personal information, create a new user account, manage 44the roster, and disconnect. You can use all or none of the functions, 45there is no requirement. 46 47For more information on how the details for how L<Net::XMPP> is written 48please see the help for Net::XMPP itself. 49 50For more information on writing a Client see L<Net::XMPP::Client>. 51 52=head2 Modes 53 54Several of the functions take a mode argument that let you specify how 55the function should behave: 56 57=over 4 58 59=item block 60 61send the packet with an ID, and then block until an answer 62comes back. You can optionally specify a timeout so that 63you do not block forever. 64 65=item nonblock 66 67send the packet with an ID, but then return that id and 68control to the master program. Net::XMPP is still 69tracking this packet, so you must use the CheckID function 70to tell when it comes in. (This might not be very 71useful...) 72 73=item passthru 74 75send the packet with an ID, but do NOT register it with 76Net::XMPP, then return the ID. This is useful when 77combined with the XPath function because you can register 78a one shot function tied to the id you get back. 79 80=back 81 82=head2 Basic Functions 83 84 use Net::XMPP qw( Client ); 85 $Con = Net::XMPP::Client->new(); # From 86 $status = $Con->Connect(hostname=>"jabber.org"); # Net::XMPP::Client 87 88 $Con->SetCallBacks(send=>\&sendCallBack, 89 receive=>\&receiveCallBack, 90 message=>\&messageCallBack, 91 iq=>\&handleTheIQTag); 92 93 $Con->SetMessageCallBacks(normal=>\&messageNormalCB, 94 chat=>\&messageChatCB); 95 96 $Con->SetPresenceCallBacks(available=>\&presenceAvailableCB, 97 unavailable=>\&presenceUnavailableCB); 98 99 $Con->SetIQCallBacks("custom-namespace"=> 100 { 101 get=>\&iqCustomGetCB, 102 set=>\&iqCustomSetCB, 103 result=>\&iqCustomResultCB, 104 }, 105 etc... 106 ); 107 108 $Con->SetXPathCallBacks("/message[@type='chat']"=>&messageChatCB, 109 "/message[@type='chat']"=>&otherMessageChatCB, 110 ... 111 ); 112 113 $Con->RemoveXPathCallBacks("/message[@type='chat']"=>&otherMessageChatCB); 114 115 $Con->SetDirectXPathCallBacks("/anything"=>&anythingCB, 116 "/anotherthing[@foo='bar']"=>&anotherthingFooBarCB, 117 ... 118 ); 119 120 $Con->RemoveDirectXPathCallBacks("/message[@type='chat']"=>&otherMessageChatCB); 121 122 $error = $Con->GetErrorCode(); 123 $Con->SetErrorCode("Timeout limit reached"); 124 125 $status = $Con->Process(); 126 $status = $Con->Process(5); 127 128 $Con->Send($object); 129 $Con->Send("<tag>XML</tag>"); 130 131 $Con->Send($object,1); 132 $Con->Send("<tag>XML</tag>",1); 133 134 $Con->Disconnect(); 135 136=head2 ID Functions 137 138 $id = $Con->SendWithID($sendObj); 139 $id = $Con->SendWithID("<tag>XML</tag>"); 140 $receiveObj = $Con->SendAndReceiveWithID($sendObj); 141 $receiveObj = $Con->SendAndReceiveWithID($sendObj, 142 10); 143 $receiveObj = $Con->SendAndReceiveWithID("<tag>XML</tag>"); 144 $receiveObj = $Con->SendAndReceiveWithID("<tag>XML</tag>", 145 5); 146 $yesno = $Con->ReceivedID($id); 147 $receiveObj = $Con->GetID($id); 148 $receiveObj = $Con->WaitForID($id); 149 $receiveObj = $Con->WaitForID($id, 150 20); 151 152=head2 Namespace Functions 153 154 $Con->AddNamespace(ns=>"foo:bar", 155 tag=>"myfoo", 156 xpath=>{Foo=>{ path=> "foo/text()" }, 157 Bar=>{ path=> "bar/text()" }, 158 FooBar=>{ type=> "master" }, 159 } 160 ); 161 162=head2 Message Functions 163 164 $Con->MessageSend(to=>"bob@jabber.org", 165 subject=>"Lunch", 166 body=>"Let's go grab some...\n", 167 thread=>"ABC123", 168 priority=>10); 169 170=head2 Presence Functions 171 172 $Con->PresenceSend(); 173 $Con->PresenceSend(type=>"unavailable"); 174 $Con->PresenceSend(show=>"away"); 175 $Con->PresenceSend(signature=>...signature...); 176 177=head2 Subscription Functions 178 179 $Con->Subscription(type=>"subscribe", 180 to=>"bob@jabber.org"); 181 182 $Con->Subscription(type=>"unsubscribe", 183 to=>"bob@jabber.org"); 184 185 $Con->Subscription(type=>"subscribed", 186 to=>"bob@jabber.org"); 187 188 $Con->Subscription(type=>"unsubscribed", 189 to=>"bob@jabber.org"); 190 191=head2 Presence DB Functions 192 193 $Con->PresenceDB(); 194 195 $Con->PresenceDBParse(Net::XMPP::Presence); 196 197 $Con->PresenceDBDelete("bob\@jabber.org"); 198 $Con->PresenceDBDelete(Net::XMPP::JID); 199 200 $Con->PresenceDBClear(); 201 202 $presence = $Con->PresenceDBQuery("bob\@jabber.org"); 203 $presence = $Con->PresenceDBQuery(Net::XMPP::JID); 204 205 @resources = $Con->PresenceDBResources("bob\@jabber.org"); 206 @resources = $Con->PresenceDBResources(Net::XMPP::JID); 207 208=head2 IQ Functions 209 210=head2 Auth Functions 211 212 @result = $Con->AuthSend(); 213 @result = $Con->AuthSend(username=>"bob", 214 password=>"bobrulez", 215 resource=>"Bob"); 216 217=head2 Register Functions 218 219 %hash = $Con->RegisterRequest(); 220 %hash = $Con->RegisterRequest(to=>"transport.jabber.org"); 221 %hash = $Con->RegisterRequest(to=>"transport.jabber.org", 222 timeout=>10); 223 224 @result = $Con->RegisterSend(to=>"somewhere", 225 username=>"newuser", 226 resource=>"New User", 227 password=>"imanewbie", 228 email=>"newguy@new.com", 229 key=>"some key"); 230 231=head2 Roster Functions 232 233 $Roster = $Con->Roster(); 234 235 %roster = $Con->RosterParse($iq); 236 %roster = $Con->RosterGet(); 237 $Con->RosterRequest(); 238 $Con->RosterAdd(jid=>"bob\@jabber.org", 239 name=>"Bob"); 240 $Con->RosterRemove(jid=>"bob@jabber.org"); 241 242=head2 Roster DB Functions 243 244 $Con->RosterDB(); 245 246 $Con->RosterDBParse(Net::XMPP::IQ); 247 248 $Con->RosterDBAdd("bob\@jabber.org", 249 name=>"Bob", 250 groups=>["foo"] 251 ); 252 253 $Con->RosterDBRemove("bob\@jabber.org"); 254 $Con->RosterDBRemove(Net::XMPP::JID); 255 256 $Con->RosterDBClear(); 257 258 if ($Con->RosterDBExists("bob\@jabber.org")) { ... 259 if ($Con->RosterDBExists(Net::XMPP::JID)) { ... 260 261 @jids = $Con->RosterDBJIDs(); 262 263 if ($Con->RosterDBGroupExists("foo")) { ... 264 265 @groups = $Con->RosterDBGroups(); 266 267 @jids = $Con->RosterDBGroupJIDs("foo"); 268 269 @jids = $Con->RosterDBNonGroupJIDs(); 270 271 %hash = $Con->RosterDBQuery("bob\@jabber.org"); 272 %hash = $Con->RosterDBQuery(Net::XMPP::JID); 273 274 $value = $Con->RosterDBQuery("bob\@jabber.org","name"); 275 $value = $Con->RosterDBQuery(Net::XMPP::JID,"groups"); 276 277 278=head1 METHODS 279 280=head2 Basic Functions 281 282=over 4 283 284=item GetErrorCode() 285 286returns a string that will hopefully contain some 287useful information about why a function returned 288an undef to you. 289 290=item SetErrorCode 291 292 SetErrorCode(string) 293 294set a useful error message before you return 295an undef to the caller. 296 297=item SetCallBacks 298 299 SetCallBacks(message=>function, 300 presence=>function, 301 iq=>function, 302 send=>function, 303 receive=>function, 304 update=>function) 305 306 307sets the callback functions for 308the top level tags listed. The 309available tags to look for are 310<message/>, <presence/>, and 311<iq/>. If a packet is received 312with an ID which is found in the 313registered ID list (see RegisterID 314below) then it is not sent to 315these functions, instead it 316is inserted into a LIST and can 317be retrieved by some functions 318we will mention later. 319 320send and receive are used to 321log what XML is sent and received. 322update is used as way to update 323your program while waiting for 324a packet with an ID to be 325returned (useful for GUI apps). 326 327A major change that came with 328the last release is that the 329session id is passed to the 330callback as the first argument. 331This was done to facilitate 332the Server module. 333 334The next argument depends on 335which callback you are talking 336about. message, presence, and iq 337all get passed in Net::XMPP 338objects that match those types. 339send and receive get passed in 340strings. update gets passed 341nothing, not even the session id. 342 343If you set the function to undef, 344then the callback is removed from 345the list. 346 347=item SetPresenceCallBacks 348 349 SetPresenceCallBacks(type=>function etc...) 350 351sets the callback functions for 352the specified presence type. 353The function takes types as the 354main key, and lets you specify 355a function for each type of 356packet you can get. 357 358 "available" 359 "unavailable" 360 "subscribe" 361 "unsubscribe" 362 "subscribed" 363 "unsubscribed" 364 "probe" 365 "error" 366 367When it gets a <presence/> 368packet it checks the type='' 369for a defined callback. If 370there is one then it calls the 371function with two arguments: 372 373 the session ID, and the 374 Net::XMPP::Presence object. 375 376If you set the function to 377undef, then the callback is 378removed from the list. 379 380NOTE: If you use this, which is a cleaner method, 381then you must *NOT* specify a callback for 382presence in the SetCallBacks function. 383 384 Net::XMPP defines a few default 385 callbacks for various types: 386 387 "subscribe" - 388 replies with subscribed 389 390 "unsubscribe" - 391 replies with unsubscribed 392 393 "subscribed" - 394 replies with subscribed 395 396 "unsubscribed" - 397 replies with unsubscribed 398 399=item SetMessageCallBacks 400 401 SetMessageCallBacks(type=>function, etc...) 402 403sets the callback functions for 404the specified message type. The 405function takes types as the 406main key, and lets you specify 407a function for each type of 408packet you can get. 409 410 "normal" 411 "chat" 412 "groupchat" 413 "headline" 414 "error" 415 416When it gets a <message/> packet 417it checks the type='' for a 418defined callback. If there is 419one then it calls the function 420with two arguments: 421 422 the session ID, and the 423 Net::XMPP::Message object. 424 425If you set the function to 426undef, then the callback is 427removed from the list. 428 429NOTE: If you use this, which is a cleaner method, 430then you must *NOT* specify a callback for 431message in the SetCallBacks function. 432 433=item SetIQCallBacks 434 435 SetIQCallBacks(namespace=>{ 436 get=>function, 437 set=>function, 438 result=>function 439 }, 440 etc...) 441 442 443sets the callback functions for 444the specified namespace. The 445function takes namespaces as the 446main key, and lets you specify a 447function for each type of packet 448you can get. 449 450 "get" 451 "set" 452 "result" 453 454When it gets an <iq/> packet it 455checks the type='' and the 456xmlns='' for a defined callback. 457If there is one then it calls 458the function with two arguments: 459the session ID, and the 460Net::XMPP::xxxx object. 461 462If you set the function to undef, 463then the callback is removed from 464the list. 465 466NOTE: If you use this, which is a cleaner method, 467then you must *NOT* specify a callback for 468iq in the SetCallBacks function. 469 470=item SetXPathCallBacks 471 472 473 SetXPathCallBacks(xpath=>function, etc...) 474 475registers a callback function 476for each xpath specified. If 477Net::XMPP matches the xpath, 478then it calls the function with 479two arguments: 480 481 the session ID, and the 482 Net::XMPP::Message object. 483 484Xpaths are rooted at each 485packet: 486 487 /message[@type="chat"] 488 /iq/*[xmlns="jabber:iq:roster"][1] 489 ... 490 491 492=item RemoveXPathCallBacks 493 494 RemoveXPathCallBacks(xpath=>function, etc...) 495 496unregisters a callback 497function for each xpath 498specified. 499 500=item SetDirectXPathCallBacks 501 502 SetDirectXPathCallBacks(xpath=>function, etc...) 503 504registers a callback function 505for each xpath specified. If 506Net::XMPP matches the xpath, 507then it calls the function with 508two arguments: 509 510 the session ID, and the 511 XML::Stream::Node object. 512 513Xpaths are rooted at each 514packet: 515 516 /anything 517 /anotherthing/foo/[1] 518 ... 519 520The big difference between this 521and regular XPathCallBacks is 522the fact that this passes in 523the XML directly and not a 524Net::XMPP based object. 525 526=item RemoveDirectXPathCallBacks 527 528 RemoveDirectXPathCallBacks(xpath=>function, etc...) 529 530unregisters a callback 531function for each xpath 532specified. 533 534=item Process 535 536 Process(integer) 537takes the timeout period as an argument. If no 538timeout is listed then the function blocks until 539a packet is received. Otherwise it waits that 540number of seconds and then exits so your program 541can continue doing useful things. NOTE: This is 542important for GUIs. You need to leave time to 543process GUI commands even if you are waiting for 544packets. The following are the possible return 545values, and what they mean: 546 547 1 - Status ok, data received. 548 0 - Status ok, no data received. 549 undef - Status not ok, stop processing. 550 551IMPORTANT: You need to check the output of every 552Process. If you get an undef then the connection 553died and you should behave accordingly. 554 555=item Send 556 557 Send(object, ignoreActivity) 558 Send(string, ignoreActivity) 559 560takes either a Net::XMPP::xxxxx object or 561an XML string as an argument and sends it to 562the server. If you set ignoreActivty to 1, 563then the XML::Stream module will not record 564this packet as couting towards user activity. 565 566=back 567 568=head2 ID Functions 569 570=over 571 572=item SendWithID 573 574 SendWithID(object) 575 SendWithID(string) 576 577takes either a Net::XMPP::xxxxx object or an 578XML string as an argument, adds the next 579available ID number and sends that packet to 580the server. Returns the ID number assigned. 581 582=item SendAndReceiveWithID 583 584 SendAndReceiveWithID(object, timeout) 585 SendAndReceiveWithID(string, timeout) 586 587uses SendWithID and WaitForID to 588provide a complete way to send and 589receive packets with IDs. Can take 590either a Net::XMPP::xxxxx object 591or an XML string. Returns the 592proper Net::XMPP::xxxxx object 593based on the type of packet 594received. The timeout is passed 595on to WaitForID, see that function 596for how the timeout works. 597 598=item ReceivedID 599 600 ReceivedID(integer) 601 602returns 1 if a packet has been received with 603specified ID, 0 otherwise. 604 605=item GetID 606 607 GetID(integer) 608 609returns the proper Net::XMPP::xxxxx object based 610on the type of packet received with the specified 611ID. If the ID has been received the GetID returns 0. 612 613=item WaitForID 614 615 WaitForID(integer, timeout) 616 617blocks until a packet with the ID is received. 618Returns the proper Net::XMPP::xxxxx object 619based on the type of packet received. If the 620timeout limit is reached then if the packet 621does come in, it will be discarded. 622 623 624NOTE: Only <iq/> officially support ids, so sending a <message/>, or 625<presence/> with an id is a risk. The server will ignore the 626id tag and pass it through, so both clients must support the 627id tag for these functions to be useful. 628 629=back 630 631=head2 Namespace Functions 632 633=over 4 634 635=item AddNamespace 636 637 AddNamespace(ns=>string, 638 tag=>string, 639 xpath=>hash) 640 641This function is very complex. 642It is a little too complex to 643discuss within the confines of 644this small paragraph. Please 645refer to the man page for 646Net::XMPP::Namespaces for the 647full documentation on this 648subject. 649 650=back 651 652=head2 Message Functions 653 654=over 4 655 656=item MessageSend 657 658 MessageSend(hash) 659 660takes the hash and passes it to SetMessage in 661Net::XMPP::Message (refer there for valid 662settings). Then it sends the message to the 663server. 664 665=back 666 667=head2 Presence Functions 668 669=over 4 670 671=item PresenceSend 672 673 PresenceSend() 674 PresenceSend(hash, signature=>string) 675 676No arguments will send an empty 677Presence to the server to tell it 678that you are available. If you 679provide a hash, then it will pass 680that hash to the SetPresence() 681function as defined in the 682Net::XMPP::Presence module. 683Optionally, you can specify a 684signature and a jabber:x:signed 685will be placed in the <presence/>. 686 687=back 688 689=head2 Subscription Functions 690 691=over 4 692 693=item Subscription 694 695 Subscription(hash) 696 697taks the hash and passes it to SetPresence in 698Net::XMPP::Presence (refer there for valid 699settings). Then it sends the subscription to 700server. 701 702The valid types of subscription are: 703 704 subscribe - subscribe to JID's presence 705 unsubscribe - unsubscribe from JID's presence 706 subscribed - response to a subscribe 707 unsubscribed - response to an unsubscribe 708 709=back 710 711=head2 Presence DB Functions 712 713=over 4 714 715=item PresenceDB 716 717 PresenceDB() 718 719Tell the object to initialize the callbacks to 720automatically populate the Presence DB. 721 722=item PresenceDBParse 723 724 PresenceDBParse(Net::XMPP::Presence) 725 726for every presence that you 727receive pass the Presence 728object to the DB so that 729it can track the resources 730and priorities for you. 731Returns either the presence 732passed in, if it not able 733to parsed for the DB, or the 734current presence as found by 735the PresenceDBQuery 736function. 737 738=item PresenceDBDelete 739 740 PresenceDBDelete(string|Net::XMPP::JID) 741 742delete thes JID entry from the DB. 743 744=item PresenceDBClear 745 746 PresenceDBClear() 747 748delete all entries in the database. 749 750=item PresenceDBQuery 751 752 PresenceDBQuery(string|Net::XMPP::JID) 753 754returns the NX::Presence 755that was last received for 756the highest priority of 757this JID. You can pass 758it a string or a NX::JID 759object. 760 761=item PresenceDBResources 762 763 PresenceDBResources(string|Net::XMPP::JID) 764 765returns an array of 766resources in order 767from highest priority 768to lowest. 769 770=back 771 772=head2 IQ Functions 773 774=head2 Auth Functions 775 776=over 4 777 778=item AuthSend 779 780 AuthSend(username=>string, 781 password=>string, 782 resource=>string) 783 784takes all of the information and 785builds a L<Net::XMPP::IQ::Auth> packet. 786It then sends that packet to the 787server with an ID and waits for that 788ID to return. Then it looks in 789resulting packet and determines if 790authentication was successful for not. 791The array returned from AuthSend looks 792like this: 793 794 [ type , message ] 795 796If type is "ok" then authentication 797was successful, otherwise message 798contains a little more detail about the 799error. 800 801=back 802 803=head2 IQ::Register Functions 804 805 806=over 4 807 808=item RegisterRequest 809 810 RegisterRequest(to=>string, timeout=>int) 811 RegisterRequest() 812 813send an <iq/> request to the specified 814server/transport, if not specified it 815sends to the current active server. 816The function returns a hash that 817contains the required fields. Here 818is an example of the hash: 819 820$hash{fields} - The raw fields from 821 the iq:register. 822 To be used if there 823 is no x:data in the 824 packet. 825 826$hash{instructions} - How to fill out 827 the form. 828 829$hash{form} - The new dynamic forms. 830 831In $hash{form}, the fields that are 832present are the required fields the 833server needs. 834 835=item RegisterSend 836 837 RegisterSend(hash) 838 839takes the contents of the hash and passes it 840to the SetRegister function in the module 841Net::XMPP::Query jabber:iq:register namespace. 842This function returns an array that looks like 843this: 844 845 [ type , message ] 846 847If type is "ok" then registration was 848successful, otherwise message contains a 849little more detail about the error. 850 851=back 852 853 854=head2 Roster Functions 855 856=over 4 857 858=item Roster 859 860 Roster() 861 862returns a L<Net::XMPP::Roster> object. This will automatically 863intercept all of the roster and presence packets sent from 864the server and give you an accurate Roster. For more 865information please read the man page for Net::XMPP::Roster. 866 867=item RosterParse 868 869 RosterParse(IQ object) 870 871returns a hash that contains the roster 872parsed into the following data structure: 873 874 $roster{'bob@jabber.org'}->{name} 875 - Name you stored in the roster 876 877 $roster{'bob@jabber.org'}->{subscription} 878 - Subscription status 879 (to, from, both, none) 880 881 $roster{'bob@jabber.org'}->{ask} 882 - The ask status from this user 883 (subscribe, unsubscribe) 884 885 $roster{'bob@jabber.org'}->{groups} 886 - Array of groups that 887 bob@jabber.org is in 888 889=item RosterGet 890 891 RosterGet() 892 893sends an empty Net::XMPP::IQ::Roster tag to the 894server so the server will send the Roster to the 895client. Returns the above hash from RosterParse. 896 897=item RosterRequest 898 899 RosterRequest() 900 901sends an empty Net::XMPP::IQ::Roster tag to the 902server so the server will send the Roster to the 903client. 904 905=item RosterAdd 906 907 RosterAdd(hash) 908 909sends a packet asking that the jid be 910added to the roster. The hash format 911is defined in the SetItem function 912in the Net::XMPP::Query jabber:iq:roster 913namespace. 914 915=item RosterRemove 916 917 RosterRemove(hash) 918 919sends a packet asking that the jid be 920removed from the roster. The hash 921format is defined in the SetItem function 922in the Net::XMPP::Query jabber:iq:roster 923namespace. 924 925=back 926 927=head2 Roster DB Functions 928 929=over 4 930 931=item RosterDB 932 933 RosterDB() 934 935Tell the object to initialize the callbacks to 936automatically populate the Roster DB. If you do this, 937then make sure that you call RosterRequest() instead of 938RosterGet() so that the callbacks can catch it and 939parse it. 940 941=item RosterDBParse 942 943 RosterDBParse(IQ object) 944 945If you want to manually control the 946database, then you can pass in all iq 947packets with jabber:iq:roster queries to 948this function. 949 950=item RosterDBAdd 951 952 RosterDBAdd(jid,hash) 953 954Add a new JID into the roster DB. The JID 955is either a string, or a Net::XMPP::JID 956object. The hash must be the same format as 957the has returned by RosterParse above, and 958is the actual hash, not a reference. 959 960=item RosterDBRemove 961 962 RosterDBRemove(jid) 963 964Remove a JID from the roster DB. The JID is 965either a string, or a Net::XMPP::JID object. 966 967=item RosterDBClear 968 969Remove all JIDs from the roster DB. 970 971=item RosterDBExists 972 973 RosterDBExists(jid) 974 975return 1 if the JID exists in the roster DB, 976undef otherwise. The JID is either a string, 977or a Net::XMPP::JID object. 978 979=item RosterDBJIDs 980 981 RosterDBJIDs() 982 983returns a list of Net::XMPP::JID objects that 984represents all of the JIDs in the DB. 985 986=item RosterDBGroups 987 988returns the complete list of roster groups in the 989roster. 990 991=item RosterDBGroupExists 992 993 RosterDBGroupExists(group) 994 995return 1 if the group is a group in the 996roster DB, undef otherwise. 997 998=item RosterDBGroupJIDs 999 1000 RosterDBGroupJIDs(group) 1001 1002returns a list of Net::XMPP::JID objects 1003that represents all of the JIDs in the 1004specified roster group. 1005 1006=item RosterDBNonGroupJIDs 1007 1008returns a list of Net::XMPP::JID objects 1009that represents all of the JIDs not in a 1010roster group. 1011 1012=item RosterDBQuery 1013 1014 RosterDBQuery(jid) 1015 1016returns a hash containing the data from the 1017roster DB for the specified JID. The JID is 1018either a string, or a Net::XMPP::JID object. 1019The hash format the same as in RosterParse 1020above. 1021 1022=item RosterDBQuery 1023 1024 RosterDBQuery(jid,key) 1025 1026returns the entry from the above hash for 1027the given key. The available keys are: 1028 name, ask, subsrcription and groups 1029The JID is either a string, or a 1030L<Net::XMPP::JID> object. 1031 1032=back 1033 1034=head1 AUTHOR 1035 1036Originally authored by Ryan Eatmon. 1037 1038Previously maintained by Eric Hacker. 1039 1040Currently maintained by Darian Anthony Patrick. 1041 1042=head1 COPYRIGHT 1043 1044This module is free software, you can redistribute it and/or modify it 1045under the LGPL 2.1. 1046 1047=cut 1048 1049require 5.003; 1050use strict; 1051use warnings; 1052 1053use Carp; 1054use Digest::SHA; 1055use MIME::Base64; 1056use Authen::SASL; 1057 1058use XML::Stream; 1059 1060use Net::XMPP::IQ; 1061use Net::XMPP::Message; 1062use Net::XMPP::Presence; 1063use Net::XMPP::JID; 1064use Net::XMPP::Roster; 1065use Net::XMPP::PrivacyLists; 1066 1067use vars qw( %XMLNS %NEWOBJECT $SASL_CALLBACK $TLS_CALLBACK ); 1068 1069############################################################################## 1070# Define the namespaces in an easy/constant manner. 1071#----------------------------------------------------------------------------- 1072# 1.0 1073#----------------------------------------------------------------------------- 1074$XMLNS{'xmppstreams'} = "urn:ietf:params:xml:ns:xmpp-streams"; 1075$XMLNS{'xmpp-bind'} = "urn:ietf:params:xml:ns:xmpp-bind"; 1076$XMLNS{'xmpp-sasl'} = "urn:ietf:params:xml:ns:xmpp-sasl"; 1077$XMLNS{'xmpp-session'} = "urn:ietf:params:xml:ns:xmpp-session"; 1078$XMLNS{'xmpp-tls'} = "urn:ietf:params:xml:ns:xmpp-tls"; 1079############################################################################## 1080 1081############################################################################## 1082# BuildObject takes a root tag and builds the correct object. NEWOBJECT is 1083# the table that maps tag to package. Override these, or provide new ones. 1084#----------------------------------------------------------------------------- 1085$NEWOBJECT{'iq'} = "Net::XMPP::IQ"; 1086$NEWOBJECT{'message'} = "Net::XMPP::Message"; 1087$NEWOBJECT{'presence'} = "Net::XMPP::Presence"; 1088$NEWOBJECT{'jid'} = "Net::XMPP::JID"; 1089############################################################################## 1090 1091sub _message { shift; my $o; eval "\$o = $NEWOBJECT{'message'}->new(\@_);"; return $o; } 1092sub _presence { shift; my $o; eval "\$o = $NEWOBJECT{'presence'}->new(\@_);"; return $o; } 1093sub _iq { shift; my $o; eval "\$o = $NEWOBJECT{'iq'}->new(\@_);"; return $o; } 1094sub _jid { shift; my $o; eval "\$o = $NEWOBJECT{'jid'}->new(\@_);"; return $o; } 1095 1096############################################################################### 1097#+----------------------------------------------------------------------------- 1098#| 1099#| Base API 1100#| 1101#+----------------------------------------------------------------------------- 1102############################################################################### 1103 1104############################################################################### 1105# 1106# GetErrorCode - if you are returned an undef, you can call this function 1107# and hopefully learn more information about the problem. 1108# 1109############################################################################### 1110sub GetErrorCode 1111{ 1112 my $self = shift; 1113 return ((exists($self->{ERRORCODE}) && ($self->{ERRORCODE} ne "")) ? 1114 $self->{ERRORCODE} : 1115 $! 1116 ); 1117} 1118 1119 1120############################################################################### 1121# 1122# SetErrorCode - sets the error code so that the caller can find out more 1123# information about the problem 1124# 1125############################################################################### 1126sub SetErrorCode 1127{ 1128 my $self = shift; 1129 my ($errorcode) = @_; 1130 $self->{ERRORCODE} = $errorcode; 1131} 1132 1133 1134############################################################################### 1135# 1136# CallBack - Central callback function. If a packet comes back with an ID 1137# and the tag and ID have been registered then the packet is not 1138# returned as normal, instead it is inserted in the LIST and 1139# stored until the user wants to fetch it. If the tag and ID 1140# are not registered the function checks if a callback exists 1141# for this tag, if it does then that callback is called, 1142# otherwise the function drops the packet since it does not know 1143# how to handle it. 1144# 1145############################################################################### 1146sub CallBack 1147{ 1148 my $self = shift; 1149 my $sid = shift; 1150 my ($object) = @_; 1151 1152 my $tag; 1153 my $id; 1154 my $tree; 1155 1156 if (ref($object) !~ /^Net::XMPP/) 1157 { 1158 if ($self->{DEBUG}->GetLevel() >= 1 || exists($self->{CB}->{receive})) 1159 { 1160 my $xml = $object->GetXML(); 1161 $self->{DEBUG}->Log1("CallBack: sid($sid) received($xml)"); 1162 &{$self->{CB}->{receive}}($sid,$xml) if exists($self->{CB}->{receive}); 1163 } 1164 1165 $tag = $object->get_tag(); 1166 $id = ""; 1167 $id = $object->get_attrib("id") 1168 if defined($object->get_attrib("id")); 1169 $tree = $object; 1170 } 1171 else 1172 { 1173 $tag = $object->GetTag(); 1174 $id = $object->GetID(); 1175 $tree = $object->GetTree(); 1176 } 1177 1178 $self->{DEBUG}->Log1("CallBack: tag($tag)"); 1179 $self->{DEBUG}->Log1("CallBack: id($id)") if ($id ne ""); 1180 1181 my $pass = 1; 1182 $pass = 0 1183 if (!exists($self->{CB}->{$tag}) && 1184 !exists($self->{CB}->{XPath}) && 1185 !exists($self->{CB}->{DirectXPath}) && 1186 !$self->CheckID($tag,$id) 1187 ); 1188 1189 if ($pass) 1190 { 1191 $self->{DEBUG}->Log1("CallBack: we either want it or were waiting for it."); 1192 1193 if (exists($self->{CB}->{DirectXPath})) 1194 { 1195 $self->{DEBUG}->Log1("CallBack: check directxpath"); 1196 1197 my $direct_pass = 0; 1198 1199 foreach my $xpath (keys(%{$self->{CB}->{DirectXPath}})) 1200 { 1201 $self->{DEBUG}->Log1("CallBack: check directxpath($xpath)"); 1202 if ($object->XPathCheck($xpath)) 1203 { 1204 foreach my $func (keys(%{$self->{CB}->{DirectXPath}->{$xpath}})) 1205 { 1206 $self->{DEBUG}->Log1("CallBack: goto directxpath($xpath) function($func)"); 1207 &{$self->{CB}->{DirectXPath}->{$xpath}->{$func}}($sid,$object); 1208 $direct_pass = 1; 1209 } 1210 } 1211 } 1212 1213 return if $direct_pass; 1214 } 1215 1216 my $NXObject; 1217 if (ref($object) !~ /^Net::XMPP/) 1218 { 1219 $NXObject = $self->BuildObject($tag,$object); 1220 } 1221 else 1222 { 1223 $NXObject = $object; 1224 } 1225 1226 if ($NXObject == -1) 1227 { 1228 $self->{DEBUG}->Log1("CallBack: DANGER!! DANGER!! We didn't build a packet! We're all gonna die!!"); 1229 } 1230 else 1231 { 1232 if ($self->CheckID($tag,$id)) 1233 { 1234 $self->{DEBUG}->Log1("CallBack: found registry entry: tag($tag) id($id)"); 1235 $self->DeregisterID($tag,$id); 1236 if ($self->TimedOutID($id)) 1237 { 1238 $self->{DEBUG}->Log1("CallBack: dropping packet due to timeout"); 1239 $self->CleanID($id); 1240 } 1241 else 1242 { 1243 $self->{DEBUG}->Log1("CallBack: they still want it... we still got it..."); 1244 $self->GotID($id,$NXObject); 1245 } 1246 } 1247 else 1248 { 1249 $self->{DEBUG}->Log1("CallBack: no registry entry"); 1250 1251 if (exists($self->{CB}->{XPath})) 1252 { 1253 $self->{DEBUG}->Log1("CallBack: check xpath"); 1254 1255 foreach my $xpath (keys(%{$self->{CB}->{XPath}})) 1256 { 1257 if ($NXObject->GetTree()->XPathCheck($xpath)) 1258 { 1259 foreach my $func (keys(%{$self->{CB}->{XPath}->{$xpath}})) 1260 { 1261 $self->{DEBUG}->Log1("CallBack: goto xpath($xpath) function($func)"); 1262 &{$self->{CB}->{XPath}->{$xpath}->{$func}}($sid,$NXObject); 1263 } 1264 } 1265 } 1266 } 1267 1268 if (exists($self->{CB}->{$tag})) 1269 { 1270 $self->{DEBUG}->Log1("CallBack: goto user function($self->{CB}->{$tag})"); 1271 &{$self->{CB}->{$tag}}($sid,$NXObject); 1272 } 1273 else 1274 { 1275 $self->{DEBUG}->Log1("CallBack: no defined function. Dropping packet."); 1276 } 1277 } 1278 } 1279 } 1280 else 1281 { 1282 $self->{DEBUG}->Log1("CallBack: a packet that no one wants... how sad. =("); 1283 } 1284} 1285 1286 1287############################################################################### 1288# 1289# BuildObject - turn the packet into an object. 1290# 1291############################################################################### 1292sub BuildObject 1293{ 1294 my $self = shift; 1295 my ($tag,$tree) = @_; 1296 1297 my $obj = -1; 1298 1299 if (exists($NEWOBJECT{$tag})) 1300 { 1301 $self->{DEBUG}->Log1("BuildObject: tag($tag) package($NEWOBJECT{$tag})"); 1302 eval "\$obj = $NEWOBJECT{$tag}->new(\$tree);"; 1303 } 1304 1305 return $obj; 1306} 1307 1308 1309############################################################################### 1310# 1311# SetCallBacks - Takes a hash with top level tags to look for as the keys 1312# and pointers to functions as the values. The functions 1313# are called and passed the XML::Parser::Tree objects 1314# generated by XML::Stream. 1315# 1316############################################################################### 1317sub SetCallBacks 1318{ 1319 my $self = shift; 1320 while($#_ >= 0) 1321 { 1322 my $func = pop(@_); 1323 my $tag = pop(@_); 1324 $self->{DEBUG}->Log1("SetCallBacks: tag($tag) func($func)"); 1325 if (defined($func)) 1326 { 1327 $self->{CB}->{$tag} = $func; 1328 } 1329 else 1330 { 1331 delete($self->{CB}->{$tag}); 1332 } 1333 $self->{STREAM}->SetCallBacks(update=>$func) if ($tag eq "update"); 1334 } 1335} 1336 1337 1338############################################################################### 1339# 1340# SetIQCallBacks - define callbacks for the namespaces inside an iq. 1341# 1342############################################################################### 1343sub SetIQCallBacks 1344{ 1345 my $self = shift; 1346 1347 while($#_ >= 0) 1348 { 1349 my $hash = pop(@_); 1350 my $namespace = pop(@_); 1351 1352 foreach my $type (keys(%{$hash})) 1353 { 1354 $self->{DEBUG}->Log1("SetIQCallBacks: type($type) func($hash->{$type}) ". 1355 "namespace($namespace)"); 1356 if (defined($hash->{$type})) 1357 { 1358 $self->{CB}->{IQns}->{$namespace}->{$type} = $hash->{$type}; 1359 } 1360 else 1361 { 1362 delete($self->{CB}->{IQns}->{$namespace}->{$type}); 1363 } 1364 } 1365 } 1366} 1367 1368 1369############################################################################### 1370# 1371# SetPresenceCallBacks - define callbacks for the different presence packets. 1372# 1373############################################################################### 1374sub SetPresenceCallBacks 1375{ 1376 my $self = shift; 1377 my (%types) = @_; 1378 1379 foreach my $type (keys(%types)) 1380 { 1381 $self->{DEBUG}->Log1("SetPresenceCallBacks: type($type) func($types{$type})"); 1382 1383 if (defined($types{$type})) 1384 { 1385 $self->{CB}->{Pres}->{$type} = $types{$type}; 1386 } 1387 else 1388 { 1389 delete($self->{CB}->{Pres}->{$type}); 1390 } 1391 } 1392} 1393 1394 1395############################################################################### 1396# 1397# SetMessageCallBacks - define callbacks for the different message packets. 1398# 1399############################################################################### 1400sub SetMessageCallBacks 1401{ 1402 my $self = shift; 1403 my (%types) = @_; 1404 1405 foreach my $type (keys(%types)) 1406 { 1407 $self->{DEBUG}->Log1("SetMessageCallBacks: type($type) func($types{$type})"); 1408 1409 if (defined($types{$type})) 1410 { 1411 $self->{CB}->{Mess}->{$type} = $types{$type}; 1412 } 1413 else 1414 { 1415 delete($self->{CB}->{Mess}->{$type}); 1416 } 1417 } 1418} 1419 1420 1421############################################################################### 1422# 1423# SetXPathCallBacks - define callbacks for packets based on XPath. 1424# 1425############################################################################### 1426sub SetXPathCallBacks 1427{ 1428 my $self = shift; 1429 my (%xpaths) = @_; 1430 1431 foreach my $xpath (keys(%xpaths)) 1432 { 1433 $self->{DEBUG}->Log1("SetXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); 1434 $self->{CB}->{XPath}->{$xpath}->{$xpaths{$xpath}} = $xpaths{$xpath}; 1435 } 1436} 1437 1438 1439############################################################################### 1440# 1441# RemoveXPathCallBacks - remove callbacks for packets based on XPath. 1442# 1443############################################################################### 1444sub RemoveXPathCallBacks 1445{ 1446 my $self = shift; 1447 my (%xpaths) = @_; 1448 1449 foreach my $xpath (keys(%xpaths)) 1450 { 1451 $self->{DEBUG}->Log1("RemoveXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); 1452 delete($self->{CB}->{XPath}->{$xpath}->{$xpaths{$xpath}}); 1453 delete($self->{CB}->{XPath}->{$xpath}) 1454 if (scalar(keys(%{$self->{CB}->{XPath}->{$xpath}})) == 0); 1455 delete($self->{CB}->{XPath}) 1456 if (scalar(keys(%{$self->{CB}->{XPath}})) == 0); 1457 } 1458} 1459 1460 1461############################################################################### 1462# 1463# SetDirectXPathCallBacks - define callbacks for packets based on XPath. 1464# 1465############################################################################### 1466sub SetDirectXPathCallBacks 1467{ 1468 my $self = shift; 1469 my (%xpaths) = @_; 1470 1471 foreach my $xpath (keys(%xpaths)) 1472 { 1473 $self->{DEBUG}->Log1("SetDirectXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); 1474 $self->{CB}->{DirectXPath}->{$xpath}->{$xpaths{$xpath}} = $xpaths{$xpath}; 1475 } 1476} 1477 1478 1479############################################################################### 1480# 1481# RemoveDirectXPathCallBacks - remove callbacks for packets based on XPath. 1482# 1483############################################################################### 1484sub RemoveDirectXPathCallBacks 1485{ 1486 my $self = shift; 1487 my (%xpaths) = @_; 1488 1489 foreach my $xpath (keys(%xpaths)) 1490 { 1491 $self->{DEBUG}->Log1("RemoveDirectXPathCallBacks: xpath($xpath) func($xpaths{$xpath})"); 1492 delete($self->{CB}->{DirectXPath}->{$xpath}->{$xpaths{$xpath}}); 1493 delete($self->{CB}->{DirectXPath}->{$xpath}) 1494 if (scalar(keys(%{$self->{CB}->{DirectXPath}->{$xpath}})) == 0); 1495 delete($self->{CB}->{DirectXPath}) 1496 if (scalar(keys(%{$self->{CB}->{DirectXPath}})) == 0); 1497 } 1498} 1499 1500 1501############################################################################### 1502# 1503# Send - Takes either XML or a Net::XMPP::xxxx object and sends that 1504# packet to the server. 1505# 1506############################################################################### 1507sub Send 1508{ 1509 my $self = shift; 1510 my $object = shift; 1511 my $ignoreActivity = shift; 1512 $ignoreActivity = 0 unless defined($ignoreActivity); 1513 1514 if (ref($object) eq "") 1515 { 1516 $self->SendXML($object,$ignoreActivity); 1517 } 1518 else 1519 { 1520 $self->SendXML($object->GetXML(),$ignoreActivity); 1521 } 1522} 1523 1524 1525############################################################################### 1526# 1527# SendXML - Sends the XML packet to the server 1528# 1529############################################################################### 1530sub SendXML 1531{ 1532 my $self = shift; 1533 my $xml = shift; 1534 my $ignoreActivity = shift; 1535 $ignoreActivity = 0 unless defined($ignoreActivity); 1536 1537 $self->{DEBUG}->Log1("SendXML: sent($xml)"); 1538 &{$self->{CB}->{send}}($self->GetStreamID(),$xml) if exists($self->{CB}->{send}); 1539 $self->{STREAM}->IgnoreActivity($self->GetStreamID(),$ignoreActivity); 1540 $self->{STREAM}->Send($self->GetStreamID(),$xml); 1541 $self->{STREAM}->IgnoreActivity($self->GetStreamID(),0); 1542} 1543 1544 1545############################################################################### 1546# 1547# SendWithID - Take either XML or a Net::XMPP::xxxx object and send it 1548# with the next available ID number. Then return that ID so 1549# the client can track it. 1550# 1551############################################################################### 1552sub SendWithID 1553{ 1554 my $self = shift; 1555 my ($object) = @_; 1556 1557 #-------------------------------------------------------------------------- 1558 # Take the current XML stream and insert an id attrib at the top level. 1559 #-------------------------------------------------------------------------- 1560 my $id = $self->UniqueID(); 1561 1562 $self->{DEBUG}->Log1("SendWithID: id($id)"); 1563 1564 my $xml; 1565 if (ref($object) eq "") 1566 { 1567 $self->{DEBUG}->Log1("SendWithID: in($object)"); 1568 $xml = $object; 1569 $xml =~ s/^(\<[^\>]+)(\>)/$1 id\=\'$id\'$2/; 1570 my ($tag) = ($xml =~ /^\<(\S+)\s/); 1571 $self->RegisterID($tag,$id); 1572 } 1573 else 1574 { 1575 $self->{DEBUG}->Log1("SendWithID: in(",$object->GetXML(),")"); 1576 $object->SetID($id); 1577 $xml = $object->GetXML(); 1578 $self->RegisterID($object->GetTag(),$id); 1579 } 1580 $self->{DEBUG}->Log1("SendWithID: out($xml)"); 1581 1582 #-------------------------------------------------------------------------- 1583 # Send the new XML string. 1584 #-------------------------------------------------------------------------- 1585 $self->SendXML($xml); 1586 1587 #-------------------------------------------------------------------------- 1588 # Return the ID number we just assigned. 1589 #-------------------------------------------------------------------------- 1590 return $id; 1591} 1592 1593 1594############################################################################### 1595# 1596# UniqueID - Increment and return a new unique ID. 1597# 1598############################################################################### 1599sub UniqueID 1600{ 1601 my $self = shift; 1602 1603 my $id_num = $self->{RCVDB}->{currentID}; 1604 1605 $self->{RCVDB}->{currentID}++; 1606 1607 return "netjabber-$id_num"; 1608} 1609 1610 1611############################################################################### 1612# 1613# SendAndReceiveWithID - Take either XML or a Net::XMPP::xxxxx object and 1614# send it with the next ID. Then wait for that ID 1615# to come back and return the response in a 1616# Net::XMPP::xxxx object. 1617# 1618############################################################################### 1619sub SendAndReceiveWithID 1620{ 1621 my $self = shift; 1622 my ($object,$timeout) = @_; 1623 &{$self->{CB}->{startwait}}() if exists($self->{CB}->{startwait}); 1624 $self->{DEBUG}->Log1("SendAndReceiveWithID: object($object)"); 1625 my $id = $self->SendWithID($object); 1626 $self->{DEBUG}->Log1("SendAndReceiveWithID: sent with id($id)"); 1627 my $packet = $self->WaitForID($id,$timeout); 1628 &{$self->{CB}->{endwait}}() if exists($self->{CB}->{endwait}); 1629 return $packet; 1630} 1631 1632 1633############################################################################### 1634# 1635# ReceivedID - returns 1 if a packet with the ID has been received, or 0 1636# if it has not. 1637# 1638############################################################################### 1639sub ReceivedID 1640{ 1641 my $self = shift; 1642 my ($id) = @_; 1643 1644 $self->{DEBUG}->Log1("ReceivedID: id($id)"); 1645 return 1 if exists($self->{RCVDB}->{$id}); 1646 $self->{DEBUG}->Log1("ReceivedID: nope..."); 1647 return 0; 1648} 1649 1650 1651############################################################################### 1652# 1653# GetID - Return the Net::XMPP::xxxxx object that is stored in the LIST 1654# that matches the ID if that ID exists. Otherwise return 0. 1655# 1656############################################################################### 1657sub GetID 1658{ 1659 my $self = shift; 1660 my ($id) = @_; 1661 1662 $self->{DEBUG}->Log1("GetID: id($id)"); 1663 return $self->{RCVDB}->{$id} if $self->ReceivedID($id); 1664 $self->{DEBUG}->Log1("GetID: haven't gotten that id yet..."); 1665 return 0; 1666} 1667 1668 1669############################################################################### 1670# 1671# CleanID - Delete the list entry for this id since we don't want a leak. 1672# 1673############################################################################### 1674sub CleanID 1675{ 1676 my $self = shift; 1677 my ($id) = @_; 1678 1679 $self->{DEBUG}->Log1("CleanID: id($id)"); 1680 delete($self->{RCVDB}->{$id}); 1681} 1682 1683 1684############################################################################### 1685# 1686# WaitForID - Keep looping and calling Process(1) to poll every second 1687# until the response from the server occurs. 1688# 1689############################################################################### 1690sub WaitForID 1691{ 1692 my $self = shift; 1693 my ($id,$timeout) = @_; 1694 $timeout = "300" unless defined($timeout); 1695 1696 $self->{DEBUG}->Log1("WaitForID: id($id)"); 1697 my $endTime = time + $timeout; 1698 while(!$self->ReceivedID($id) && ($endTime >= time)) 1699 { 1700 $self->{DEBUG}->Log1("WaitForID: haven't gotten it yet... let's wait for more packets"); 1701 return unless (defined($self->Process(1))); 1702 &{$self->{CB}->{update}}() if exists($self->{CB}->{update}); 1703 } 1704 if (!$self->ReceivedID($id)) 1705 { 1706 $self->TimeoutID($id); 1707 $self->{DEBUG}->Log1("WaitForID: timed out..."); 1708 return; 1709 } 1710 else 1711 { 1712 $self->{DEBUG}->Log1("WaitForID: we got it!"); 1713 my $packet = $self->GetID($id); 1714 $self->CleanID($id); 1715 return $packet; 1716 } 1717} 1718 1719 1720############################################################################### 1721# 1722# GotID - Callback to store the Net::XMPP::xxxxx object in the LIST at 1723# the ID index. This is a private helper function. 1724# 1725############################################################################### 1726sub GotID 1727{ 1728 my $self = shift; 1729 my ($id,$object) = @_; 1730 1731 $self->{DEBUG}->Log1("GotID: id($id) xml(",$object->GetXML(),")"); 1732 $self->{RCVDB}->{$id} = $object; 1733} 1734 1735 1736############################################################################### 1737# 1738# CheckID - Checks the ID registry if this tag and ID have been registered. 1739# 0 = no, 1 = yes 1740# 1741############################################################################### 1742sub CheckID 1743{ 1744 my $self = shift; 1745 my ($tag,$id) = @_; 1746 $id = "" unless defined($id); 1747 1748 $self->{DEBUG}->Log1("CheckID: tag($tag) id($id)"); 1749 return 0 if ($id eq ""); 1750 $self->{DEBUG}->Log1("CheckID: we have that here somewhere..."); 1751 return exists($self->{IDRegistry}->{$tag}->{$id}); 1752} 1753 1754 1755############################################################################### 1756# 1757# TimeoutID - Timeout the tag and ID in the registry so that the CallBack 1758# can know what to put in the ID list and what to pass on. 1759# 1760############################################################################### 1761sub TimeoutID 1762{ 1763 my $self = shift; 1764 my ($id) = @_; 1765 1766 $self->{DEBUG}->Log1("TimeoutID: id($id)"); 1767 $self->{RCVDB}->{$id} = 0; 1768} 1769 1770 1771############################################################################### 1772# 1773# TimedOutID - Timeout the tag and ID in the registry so that the CallBack 1774# can know what to put in the ID list and what to pass on. 1775# 1776############################################################################### 1777sub TimedOutID 1778{ 1779 my $self = shift; 1780 my ($id) = @_; 1781 1782 return (exists($self->{RCVDB}->{$id}) && ($self->{RCVDB}->{$id} == 0)); 1783} 1784 1785 1786############################################################################### 1787# 1788# RegisterID - Register the tag and ID in the registry so that the CallBack 1789# can know what to put in the ID list and what to pass on. 1790# 1791############################################################################### 1792sub RegisterID 1793{ 1794 my $self = shift; 1795 my ($tag,$id) = @_; 1796 1797 $self->{DEBUG}->Log1("RegisterID: tag($tag) id($id)"); 1798 $self->{IDRegistry}->{$tag}->{$id} = 1; 1799} 1800 1801 1802############################################################################### 1803# 1804# DeregisterID - Delete the tag and ID in the registry so that the CallBack 1805# can knows that it has been received. 1806# 1807############################################################################### 1808sub DeregisterID 1809{ 1810 my $self = shift; 1811 my ($tag,$id) = @_; 1812 1813 $self->{DEBUG}->Log1("DeregisterID: tag($tag) id($id)"); 1814 delete($self->{IDRegistry}->{$tag}->{$id}); 1815} 1816 1817 1818############################################################################### 1819# 1820# AddNamespace - Add a custom namespace into the mix. 1821# 1822############################################################################### 1823sub AddNamespace 1824{ 1825 my $self = shift; 1826 &Net::XMPP::Namespaces::add_ns(@_); 1827} 1828 1829 1830############################################################################### 1831# 1832# MessageSend - Takes the same hash that Net::XMPP::Message->SetMessage 1833# takes and sends the message to the server. 1834# 1835############################################################################### 1836sub MessageSend 1837{ 1838 my $self = shift; 1839 1840 my $mess = $self->_message(); 1841 $mess->SetMessage(@_); 1842 $self->Send($mess); 1843} 1844 1845 1846############################################################################## 1847# 1848# PresenceDB - initialize the module to use the presence database 1849# 1850############################################################################## 1851sub PresenceDB 1852{ 1853 my $self = shift; 1854 1855 $self->SetXPathCallBacks('/presence'=>sub{ shift; $self->PresenceDBParse(@_) }); 1856} 1857 1858 1859############################################################################### 1860# 1861# PresenceDBParse - adds the presence information to the Presence DB so 1862# you can keep track of the current state of the JID and 1863# all of it's resources. 1864# 1865############################################################################### 1866sub PresenceDBParse 1867{ 1868 my $self = shift; 1869 my ($presence) = @_; 1870 1871 $self->{DEBUG}->Log4("PresenceDBParse: pres(",$presence->GetXML(),")"); 1872 1873 my $type = $presence->GetType(); 1874 $type = "" unless defined($type); 1875 return $presence unless (($type eq "") || 1876 ($type eq "available") || 1877 ($type eq "unavailable")); 1878 1879 my $fromJID = $presence->GetFrom("jid"); 1880 my $fromID = $fromJID->GetJID(); 1881 $fromID = "" unless defined($fromID); 1882 my $resource = $fromJID->GetResource(); 1883 $resource = " " unless ($resource ne ""); 1884 my $priority = $presence->GetPriority(); 1885 $priority = 0 unless defined($priority); 1886 1887 $self->{DEBUG}->Log1("PresenceDBParse: fromJID(",$fromJID->GetJID("full"),") resource($resource) priority($priority) type($type)"); 1888 $self->{DEBUG}->Log2("PresenceDBParse: xml(",$presence->GetXML(),")"); 1889 1890 if (exists($self->{PRESENCEDB}->{$fromID})) 1891 { 1892 my $oldPriority = $self->{PRESENCEDB}->{$fromID}->{resources}->{$resource}; 1893 $oldPriority = "" unless defined($oldPriority); 1894 1895 my $loc = 0; 1896 foreach my $index (0..$#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}}) 1897 { 1898 $loc = $index 1899 if ($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}->[$index]->{resource} eq $resource); 1900 } 1901 splice(@{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}},$loc,1); 1902 delete($self->{PRESENCEDB}->{$fromID}->{resources}->{$resource}); 1903 delete($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}) 1904 if (exists($self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}) && 1905 ($#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$oldPriority}} == -1)); 1906 delete($self->{PRESENCEDB}->{$fromID}) 1907 if (scalar(keys(%{$self->{PRESENCEDB}->{$fromID}})) == 0); 1908 1909 $self->{DEBUG}->Log1("PresenceDBParse: remove ",$fromJID->GetJID("full")," from the DB"); 1910 } 1911 1912 if (($type eq "") || ($type eq "available")) 1913 { 1914 my $loc = -1; 1915 foreach my $index (0..$#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}}) { 1916 $loc = $index 1917 if ($self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$index]->{resource} eq $resource); 1918 } 1919 $loc = $#{$self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}}+1 1920 if ($loc == -1); 1921 $self->{PRESENCEDB}->{$fromID}->{resources}->{$resource} = $priority; 1922 $self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$loc]->{presence} = 1923 $presence; 1924 $self->{PRESENCEDB}->{$fromID}->{priorities}->{$priority}->[$loc]->{resource} = 1925 $resource; 1926 1927 $self->{DEBUG}->Log1("PresenceDBParse: add ",$fromJID->GetJID("full")," to the DB"); 1928 } 1929 1930 my $currentPresence = $self->PresenceDBQuery($fromJID); 1931 return (defined($currentPresence) ? $currentPresence : $presence); 1932} 1933 1934 1935############################################################################### 1936# 1937# PresenceDBDelete - delete the JID from the DB completely. 1938# 1939############################################################################### 1940sub PresenceDBDelete 1941{ 1942 my $self = shift; 1943 my ($jid) = @_; 1944 1945 my $indexJID = $jid; 1946 $indexJID = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID')); 1947 1948 return if !exists($self->{PRESENCEDB}->{$indexJID}); 1949 delete($self->{PRESENCEDB}->{$indexJID}); 1950 $self->{DEBUG}->Log1("PresenceDBDelete: delete ",$indexJID," from the DB"); 1951} 1952 1953 1954############################################################################### 1955# 1956# PresenceDBClear - delete all of the JIDs from the DB completely. 1957# 1958############################################################################### 1959sub PresenceDBClear 1960{ 1961 my $self = shift; 1962 1963 $self->{DEBUG}->Log1("PresenceDBClear: clearing the database"); 1964 foreach my $indexJID (keys(%{$self->{PRESENCEDB}})) 1965 { 1966 $self->{DEBUG}->Log3("PresenceDBClear: deleting ",$indexJID," from the DB"); 1967 delete($self->{PRESENCEDB}->{$indexJID}); 1968 } 1969 $self->{DEBUG}->Log3("PresenceDBClear: database is empty"); 1970} 1971 1972 1973############################################################################### 1974# 1975# PresenceDBQuery - retrieve the last Net::XMPP::Presence received with 1976# the highest priority. 1977# 1978############################################################################### 1979sub PresenceDBQuery 1980{ 1981 my $self = shift; 1982 my ($jid) = @_; 1983 1984 my $indexJID = $jid; 1985 $indexJID = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID')); 1986 1987 return if !exists($self->{PRESENCEDB}->{$indexJID}); 1988 return if (scalar(keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}})) == 0); 1989 1990 my $highPriority = 1991 (sort {$b cmp $a} keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}}))[0]; 1992 1993 return $self->{PRESENCEDB}->{$indexJID}->{priorities}->{$highPriority}->[0]->{presence}; 1994} 1995 1996 1997############################################################################### 1998# 1999# PresenceDBResources - returns a list of the resources from highest 2000# priority to lowest. 2001# 2002############################################################################### 2003sub PresenceDBResources 2004{ 2005 my $self = shift; 2006 my ($jid) = @_; 2007 2008 my $indexJID = $jid; 2009 $indexJID = $jid->GetJID() if (ref $jid && $jid->isa('Net::XMPP::JID')); 2010 2011 my @resources; 2012 2013 return if !exists($self->{PRESENCEDB}->{$indexJID}); 2014 2015 foreach my $priority (sort {$b cmp $a} keys(%{$self->{PRESENCEDB}->{$indexJID}->{priorities}})) 2016 { 2017 foreach my $index (0..$#{$self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}}) 2018 { 2019 next if ($self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}->[$index]->{resource} eq " "); 2020 push(@resources,$self->{PRESENCEDB}->{$indexJID}->{priorities}->{$priority}->[$index]->{resource}); 2021 } 2022 } 2023 return @resources; 2024} 2025 2026 2027############################################################################### 2028# 2029# PresenceSend - Sends a presence tag to announce your availability 2030# 2031############################################################################### 2032sub PresenceSend 2033{ 2034 my $self = shift; 2035 my %args; 2036 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2037 2038 $args{ignoreactivity} = 0 unless exists($args{ignoreactivity}); 2039 my $ignoreActivity = delete($args{ignoreactivity}); 2040 2041 my $presence = $self->_presence(); 2042 2043 $presence->SetPresence(%args); 2044 $self->Send($presence,$ignoreActivity); 2045 return $presence; 2046} 2047 2048 2049############################################################################### 2050# 2051# PresenceProbe - Sends a presence probe to the server 2052# 2053############################################################################### 2054sub PresenceProbe 2055{ 2056 my $self = shift; 2057 my %args; 2058 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2059 delete($args{type}); 2060 2061 my $presence = $self->_presence(); 2062 $presence->SetPresence(type=>"probe", 2063 %args); 2064 $self->Send($presence); 2065} 2066 2067 2068############################################################################### 2069# 2070# Subscription - Sends a presence tag to perform the subscription on the 2071# specified JID. 2072# 2073############################################################################### 2074sub Subscription 2075{ 2076 my $self = shift; 2077 2078 my $presence = $self->_presence(); 2079 $presence->SetPresence(@_); 2080 $self->Send($presence); 2081} 2082 2083 2084############################################################################### 2085# 2086# AuthSend - This is a self contained function to send a login iq tag with 2087# an id. Then wait for a reply what the same id to come back 2088# and tell the caller what the result was. 2089# 2090############################################################################### 2091sub AuthSend 2092{ 2093 my $self = shift; 2094 my %args; 2095 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2096 2097 carp("AuthSend requires a username arguement") 2098 unless exists($args{username}); 2099 carp("AuthSend requires a password arguement") 2100 unless exists($args{password}); 2101 2102 if($self->{STREAM}->GetStreamFeature($self->GetStreamID(),"xmpp-sasl")) 2103 { 2104 return $self->AuthSASL(%args); 2105 } 2106 2107 return $self->AuthIQAuth(%args); 2108} 2109 2110 2111############################################################################### 2112# 2113# AuthIQAuth - Try and auth using jabber:iq:auth, the old Jabber way of 2114# authenticating. 2115# 2116############################################################################### 2117sub AuthIQAuth 2118{ 2119 my $self = shift; 2120 my %args; 2121 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2122 2123 $self->{DEBUG}->Log1("AuthIQAuth: old school auth"); 2124 2125 carp("AuthIQAuth requires a resource arguement") 2126 unless exists($args{resource}); 2127 2128 my $authType = "digest"; 2129 my $token; 2130 my $sequence; 2131 2132 #-------------------------------------------------------------------------- 2133 # First let's ask the sever what all is available in terms of auth types. 2134 # If we get an error, then all we can do is digest or plain. 2135 #-------------------------------------------------------------------------- 2136 my $iqAuth = $self->_iq(); 2137 $iqAuth->SetIQ(type=>"get"); 2138 my $iqAuthQuery = $iqAuth->NewChild("jabber:iq:auth"); 2139 $iqAuthQuery->SetUsername($args{username}); 2140 $iqAuth = $self->SendAndReceiveWithID($iqAuth); 2141 2142 return unless defined($iqAuth); 2143 return ( $iqAuth->GetErrorCode() , $iqAuth->GetError() ) 2144 if ($iqAuth->GetType() eq "error"); 2145 2146 if ($iqAuth->GetType() eq "error") 2147 { 2148 $authType = "digest"; 2149 } 2150 else 2151 { 2152 $iqAuthQuery = $iqAuth->GetChild(); 2153 $authType = "plain" if $iqAuthQuery->DefinedPassword(); 2154 $authType = "digest" if $iqAuthQuery->DefinedDigest(); 2155 $authType = "zerok" if ($iqAuthQuery->DefinedSequence() && 2156 $iqAuthQuery->DefinedToken()); 2157 $token = $iqAuthQuery->GetToken() if ($authType eq "zerok"); 2158 $sequence = $iqAuthQuery->GetSequence() if ($authType eq "zerok"); 2159 } 2160 2161 $self->{DEBUG}->Log1("AuthIQAuth: authType($authType)"); 2162 2163 delete($args{digest}); 2164 delete($args{type}); 2165 2166 #-------------------------------------------------------------------------- 2167 # 0k authenticaion (http://core.jabber.org/0k.html) 2168 # 2169 # Tell the server that we want to connect this way, the server sends back 2170 # a token and a sequence number. We take that token + the password and 2171 # SHA1 it. Then we SHA1 it sequence number more times and send that hash. 2172 # The server SHA1s that hash one more time and compares it to the hash it 2173 # stored last time. IF they match, we are in and it stores the hash we sent 2174 # for the next time and decreases the sequence number, else, no go. 2175 #-------------------------------------------------------------------------- 2176 if ($authType eq "zerok") 2177 { 2178 my $hashA = Digest::SHA::sha1_hex(delete($args{password})); 2179 $args{hash} = Digest::SHA::sha1_hex($hashA.$token); 2180 2181 for (1..$sequence) 2182 { 2183 $args{hash} = Digest::SHA::sha1_hex($args{hash}); 2184 } 2185 } 2186 2187 #-------------------------------------------------------------------------- 2188 # If we have access to the SHA-1 digest algorithm then let's use it. 2189 # Remove the password from the hash, create the digest, and put the 2190 # digest in the hash instead. 2191 # 2192 # Note: Concat the Session ID and the password and then digest that 2193 # string to get the server to accept the digest. 2194 #-------------------------------------------------------------------------- 2195 if ($authType eq "digest") 2196 { 2197 my $password = delete($args{password}); 2198 $args{digest} = Digest::SHA::sha1_hex($self->GetStreamID().$password); 2199 } 2200 2201 #-------------------------------------------------------------------------- 2202 # Create a Net::XMPP::IQ object to send to the server 2203 #-------------------------------------------------------------------------- 2204 my $iqLogin = $self->_iq(); 2205 $iqLogin->SetIQ(type=>"set"); 2206 my $iqLoginQuery = $iqLogin->NewChild("jabber:iq:auth"); 2207 $iqLoginQuery->SetAuth(%args); 2208 2209 #-------------------------------------------------------------------------- 2210 # Send the IQ with the next available ID and wait for a reply with that 2211 # id to be received. Then grab the IQ reply. 2212 #-------------------------------------------------------------------------- 2213 $iqLogin = $self->SendAndReceiveWithID($iqLogin); 2214 2215 #-------------------------------------------------------------------------- 2216 # From the reply IQ determine if we were successful or not. If yes then 2217 # return "". If no then return error string from the reply. 2218 #-------------------------------------------------------------------------- 2219 return unless defined($iqLogin); 2220 return ( $iqLogin->GetErrorCode() , $iqLogin->GetError() ) 2221 if ($iqLogin->GetType() eq "error"); 2222 2223 $self->{DEBUG}->Log1("AuthIQAuth: we authed!"); 2224 2225 return ("ok",""); 2226} 2227 2228 2229############################################################################### 2230# 2231# AuthSASL - Try and auth using SASL, the XMPP preferred way of authenticating. 2232# 2233############################################################################### 2234sub AuthSASL 2235{ 2236 my $self = shift; 2237 my %args; 2238 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2239 2240 $self->{DEBUG}->Log1("AuthSASL: shiney new auth"); 2241 2242 carp("AuthSASL requires a username arguement") 2243 unless exists($args{username}); 2244 carp("AuthSASL requires a password arguement") 2245 unless exists($args{password}); 2246 2247 $args{resource} = "" unless exists($args{resource}); 2248 2249 #------------------------------------------------------------------------- 2250 # Create the SASLClient on our end 2251 #------------------------------------------------------------------------- 2252 my $sid = $self->{SESSION}->{id}; 2253 my $status = 2254 $self->{STREAM}->SASLClient($sid, 2255 $args{username}, 2256 $args{password} 2257 ); 2258 2259 $args{timeout} = "120" unless exists($args{timeout}); 2260 2261 #------------------------------------------------------------------------- 2262 # While we haven't timed out, keep waiting for the SASLClient to finish 2263 #------------------------------------------------------------------------- 2264 my $endTime = time + $args{timeout}; 2265 while(!$self->{STREAM}->SASLClientDone($sid) && ($endTime >= time)) 2266 { 2267 $self->{DEBUG}->Log1("AuthSASL: haven't authed yet... let's wait."); 2268 return unless (defined($self->Process(1))); 2269 &{$self->{CB}->{update}}() if exists($self->{CB}->{update}); 2270 } 2271 2272 #------------------------------------------------------------------------- 2273 # The loop finished... but was it done? 2274 #------------------------------------------------------------------------- 2275 if (!$self->{STREAM}->SASLClientDone($sid)) 2276 { 2277 $self->{DEBUG}->Log1("AuthSASL: timed out..."); 2278 return( "system","SASL timed out authenticating"); 2279 } 2280 2281 #------------------------------------------------------------------------- 2282 # Ok, it was done... but did we auth? 2283 #------------------------------------------------------------------------- 2284 if (!$self->{STREAM}->SASLClientAuthed($sid)) 2285 { 2286 $self->{DEBUG}->Log1("AuthSASL: Authentication failed."); 2287 return ( "error", $self->{STREAM}->SASLClientError($sid)); 2288 } 2289 2290 #------------------------------------------------------------------------- 2291 # Phew... Restart the <stream:stream> per XMPP 2292 #------------------------------------------------------------------------- 2293 $self->{DEBUG}->Log1("AuthSASL: We authed!"); 2294 $self->{SESSION} = $self->{STREAM}->OpenStream($sid); 2295 $sid = $self->{SESSION}->{id}; 2296 2297 $self->{DEBUG}->Log1("AuthSASL: We got a new session. sid($sid)"); 2298 2299 #------------------------------------------------------------------------- 2300 # Look in the new set of <stream:feature/>s and see if xmpp-bind was 2301 # offered. 2302 #------------------------------------------------------------------------- 2303 my $bind = $self->{STREAM}->GetStreamFeature($sid,"xmpp-bind"); 2304 if ($bind) 2305 { 2306 $self->{DEBUG}->Log1("AuthSASL: Binding to resource"); 2307 $self->BindResource($args{resource}); 2308 } 2309 2310 #------------------------------------------------------------------------- 2311 # Look in the new set of <stream:feature/>s and see if xmpp-session was 2312 # offered. 2313 #------------------------------------------------------------------------- 2314 my $session = $self->{STREAM}->GetStreamFeature($sid,"xmpp-session"); 2315 if ($session) 2316 { 2317 $self->{DEBUG}->Log1("AuthSASL: Starting session"); 2318 $self->StartSession(); 2319 } 2320 2321 return ("ok",""); 2322} 2323 2324 2325############################################################################## 2326# 2327# BindResource - bind to a resource 2328# 2329############################################################################## 2330sub BindResource 2331{ 2332 my $self = shift; 2333 my $resource = shift; 2334 2335 $self->{DEBUG}->Log2("BindResource: Binding to resource"); 2336 my $iq = $self->_iq(); 2337 2338 $iq->SetIQ(type=>"set"); 2339 my $bind = $iq->NewChild(&ConstXMLNS("xmpp-bind")); 2340 2341 if (defined($resource) && ($resource ne "")) 2342 { 2343 $self->{DEBUG}->Log2("BindResource: resource($resource)"); 2344 $bind->SetBind(resource=>$resource); 2345 } 2346 2347 my $result = $self->SendAndReceiveWithID($iq); 2348} 2349 2350 2351############################################################################## 2352# 2353# StartSession - Initialize a session 2354# 2355############################################################################## 2356sub StartSession 2357{ 2358 my $self = shift; 2359 2360 my $iq = $self->_iq(); 2361 2362 $iq->SetIQ(type=>"set"); 2363 my $session = $iq->NewChild(&ConstXMLNS("xmpp-session")); 2364 2365 my $result = $self->SendAndReceiveWithID($iq); 2366} 2367 2368 2369############################################################################## 2370# 2371# PrivacyLists - Initialize a Net::XMPP::PrivacyLists object and return it. 2372# 2373############################################################################## 2374sub PrivacyLists 2375{ 2376 my $self = shift; 2377 2378 return Net::XMPP::PrivacyLists->new(connection=>$self); 2379} 2380 2381 2382############################################################################## 2383# 2384# PrivacyListsGet - Sends an empty IQ to the server to request that the user's 2385# Privacy Lists be sent to them. Returns the iq packet 2386# of the result. 2387# 2388############################################################################## 2389sub PrivacyListsGet 2390{ 2391 my $self = shift; 2392 my %args; 2393 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2394 2395 my $iq = $self->_iq(); 2396 $iq->SetIQ(type=>"get"); 2397 my $query = $iq->NewChild("jabber:iq:privacy"); 2398 2399 if (exists($args{list})) 2400 { 2401 $query->AddList(name=>$args{list}); 2402 } 2403 2404 $iq = $self->SendAndReceiveWithID($iq); 2405 return unless defined($iq); 2406 2407 return $iq; 2408} 2409 2410 2411############################################################################## 2412# 2413# PrivacyListsRequest - Sends an empty IQ to the server to request that the 2414# user's privacy lists be sent to them, and return to 2415# let the user's program handle parsing the return packet. 2416# 2417############################################################################## 2418sub PrivacyListsRequest 2419{ 2420 my $self = shift; 2421 my %args; 2422 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2423 2424 my $iq = $self->_iq(); 2425 $iq->SetIQ(type=>"get"); 2426 my $query = $iq->NewChild("jabber:iq:privacy"); 2427 2428 if (exists($args{list})) 2429 { 2430 $query->AddList(name=>$args{list}); 2431 } 2432 2433 $self->Send($iq); 2434} 2435 2436 2437############################################################################## 2438# 2439# PrivacyListsSet - Sends an empty IQ to the server to request that the 2440# user's privacy lists be sent to them, and return to 2441# let the user's program handle parsing the return packet. 2442# 2443############################################################################## 2444sub PrivacyListsSet 2445{ 2446 my $self = shift; 2447 my %args; 2448 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2449 2450 my $iq = $self->_iq(); 2451 $iq->SetIQ(type=>"set"); 2452 my $query = $iq->NewChild("jabber:iq:privacy"); 2453 2454 #XXX error check that there is a list 2455 my $list = $query->AddList(name=>$args{list}); 2456 2457 foreach my $item (@{$args{items}}) 2458 { 2459 $list->AddItem(%{$item}); 2460 } 2461 2462 $iq = $self->SendAndReceiveWithID($iq); 2463 return unless defined($iq); 2464 2465 return if $iq->DefinedError(); 2466 2467 return 1; 2468} 2469 2470 2471############################################################################### 2472# 2473# RegisterRequest - This is a self contained function to send an iq tag 2474# an id that requests the target address to send back 2475# the required fields. It waits for a reply what the 2476# same id to come back and tell the caller what the 2477# fields are. 2478# 2479############################################################################### 2480sub RegisterRequest 2481{ 2482 my $self = shift; 2483 my %args; 2484 $args{mode} = "block"; 2485 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2486 2487 my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; 2488 2489 #-------------------------------------------------------------------------- 2490 # Create a Net::XMPP::IQ object to send to the server 2491 #-------------------------------------------------------------------------- 2492 my $iq = $self->_iq(); 2493 $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); 2494 $iq->SetIQ(type=>"get"); 2495 my $query = $iq->NewChild("jabber:iq:register"); 2496 2497 #-------------------------------------------------------------------------- 2498 # Send the IQ with the next available ID and wait for a reply with that 2499 # id to be received. Then grab the IQ reply. 2500 #-------------------------------------------------------------------------- 2501 if ($args{mode} eq "passthru") 2502 { 2503 my $id = $self->UniqueID(); 2504 $iq->SetIQ(id=>$id); 2505 $self->Send($iq); 2506 return $id; 2507 } 2508 2509 return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); 2510 2511 $iq = $self->SendAndReceiveWithID($iq,$timeout); 2512 2513 #-------------------------------------------------------------------------- 2514 # Check if there was an error. 2515 #-------------------------------------------------------------------------- 2516 return unless defined($iq); 2517 if ($iq->GetType() eq "error") 2518 { 2519 $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); 2520 return; 2521 } 2522 2523 my %register; 2524 #-------------------------------------------------------------------------- 2525 # From the reply IQ determine what fields are required and send a hash 2526 # back with the fields and any values that are already defined (like key) 2527 #-------------------------------------------------------------------------- 2528 $query = $iq->GetChild(); 2529 $register{fields} = { $query->GetRegister() }; 2530 2531 return %register; 2532} 2533 2534 2535############################################################################### 2536# 2537# RegisterSend - This is a self contained function to send a registration 2538# iq tag with an id. Then wait for a reply what the same 2539# id to come back and tell the caller what the result was. 2540# 2541############################################################################### 2542sub RegisterSend 2543{ 2544 my $self = shift; 2545 my %args; 2546 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2547 2548 #-------------------------------------------------------------------------- 2549 # Create a Net::XMPP::IQ object to send to the server 2550 #-------------------------------------------------------------------------- 2551 my $iq = $self->_iq(); 2552 $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); 2553 $iq->SetIQ(type=>"set"); 2554 my $iqRegister = $iq->NewChild("jabber:iq:register"); 2555 $iqRegister->SetRegister(%args); 2556 2557 #-------------------------------------------------------------------------- 2558 # Send the IQ with the next available ID and wait for a reply with that 2559 # id to be received. Then grab the IQ reply. 2560 #-------------------------------------------------------------------------- 2561 $iq = $self->SendAndReceiveWithID($iq); 2562 2563 #-------------------------------------------------------------------------- 2564 # From the reply IQ determine if we were successful or not. If yes then 2565 # return "". If no then return error string from the reply. 2566 #-------------------------------------------------------------------------- 2567 return unless defined($iq); 2568 return ( $iq->GetErrorCode() , $iq->GetError() ) 2569 if ($iq->GetType() eq "error"); 2570 return ("ok",""); 2571} 2572 2573 2574############################################################################## 2575# 2576# RosterAdd - Takes the Jabber ID of the user to add to their Roster and 2577# sends the IQ packet to the server. 2578# 2579############################################################################## 2580sub RosterAdd 2581{ 2582 my $self = shift; 2583 my %args; 2584 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2585 2586 my $iq = $self->_iq(); 2587 $iq->SetIQ(type=>"set"); 2588 my $roster = $iq->NewChild("jabber:iq:roster"); 2589 my $item = $roster->AddItem(); 2590 $item->SetItem(%args); 2591 2592 $self->{DEBUG}->Log1("RosterAdd: xml(",$iq->GetXML(),")"); 2593 $self->Send($iq); 2594} 2595 2596 2597############################################################################## 2598# 2599# RosterAdd - Takes the Jabber ID of the user to remove from their Roster 2600# and sends the IQ packet to the server. 2601# 2602############################################################################## 2603sub RosterRemove 2604{ 2605 my $self = shift; 2606 my %args; 2607 while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } 2608 delete($args{subscription}); 2609 2610 my $iq = $self->_iq(); 2611 $iq->SetIQ(type=>"set"); 2612 my $roster = $iq->NewChild("jabber:iq:roster"); 2613 my $item = $roster->AddItem(); 2614 $item->SetItem(%args, 2615 subscription=>"remove"); 2616 $self->Send($iq); 2617} 2618 2619 2620############################################################################## 2621# 2622# RosterParse - Returns a hash of roster items. 2623# 2624############################################################################## 2625sub RosterParse 2626{ 2627 my $self = shift; 2628 my($iq) = @_; 2629 2630 my %roster; 2631 my $query = $iq->GetChild("jabber:iq:roster"); 2632 2633 if (defined($query)) #$query->GetXMLNS() eq "jabber:iq:roster") 2634 { 2635 my @items = $query->GetItems(); 2636 2637 foreach my $item (@items) 2638 { 2639 my $jid = $item->GetJID(); 2640 $roster{$jid}->{name} = $item->GetName(); 2641 $roster{$jid}->{subscription} = $item->GetSubscription(); 2642 $roster{$jid}->{ask} = $item->GetAsk(); 2643 $roster{$jid}->{groups} = [ $item->GetGroup() ]; 2644 } 2645 } 2646 2647 return %roster; 2648} 2649 2650 2651############################################################################## 2652# 2653# RosterGet - Sends an empty IQ to the server to request that the user's 2654# Roster be sent to them. Returns a hash of roster items. 2655# 2656############################################################################## 2657sub RosterGet 2658{ 2659 my $self = shift; 2660 2661 my $iq = $self->_iq(); 2662 $iq->SetIQ(type=>"get"); 2663 my $query = $iq->NewChild("jabber:iq:roster"); 2664 2665 $iq = $self->SendAndReceiveWithID($iq); 2666 2667 return unless defined($iq); 2668 2669 return $self->RosterParse($iq); 2670} 2671 2672 2673############################################################################## 2674# 2675# RosterRequest - Sends an empty IQ to the server to request that the user's 2676# Roster be sent to them, and return to let the user's program 2677# handle parsing the return packet. 2678# 2679############################################################################## 2680sub RosterRequest 2681{ 2682 my $self = shift; 2683 2684 my $iq = $self->_iq(); 2685 $iq->SetIQ(type=>"get"); 2686 my $query = $iq->NewChild("jabber:iq:roster"); 2687 2688 $self->Send($iq); 2689} 2690 2691 2692############################################################################## 2693# 2694# Roster - Initialize a Net::XMPP::Roster object and return it. 2695# 2696############################################################################## 2697sub Roster 2698{ 2699 my $self = shift; 2700 2701 return Net::XMPP::Roster->new(connection=>$self); 2702} 2703 2704 2705############################################################################## 2706# 2707# RosterDB - initialize the module to use the roster database 2708# 2709############################################################################## 2710sub RosterDB 2711{ 2712 my $self = shift; 2713 2714 $self->SetXPathCallBacks('/iq[@type="result" or @type="set"]/query[@xmlns="jabber:iq:roster"]'=>sub{ shift; $self->RosterDBParse(@_) }); 2715} 2716 2717 2718############################################################################## 2719# 2720# RosterDBAdd - adds the entry to the Roster DB. 2721# 2722############################################################################## 2723sub RosterDBAdd 2724{ 2725 my $self = shift; 2726 my ($jid,%item) = @_; 2727 2728 $self->{ROSTERDB}->{JIDS}->{$jid} = \%item; 2729 2730 foreach my $group (@{$item{groups}}) 2731 { 2732 $self->{ROSTERDB}->{GROUPS}->{$group}->{$jid} = 1; 2733 } 2734} 2735 2736 2737############################################################################### 2738# 2739# RosterDBClear - delete all of the JIDs from the DB completely. 2740# 2741############################################################################### 2742sub RosterDBClear 2743{ 2744 my $self = shift; 2745 2746 $self->{DEBUG}->Log1("RosterDBClear: clearing the database"); 2747 foreach my $jid ($self->RosterDBJIDs()) 2748 { 2749 $self->{DEBUG}->Log3("RosterDBClear: deleting ",$jid->GetJID()," from the DB"); 2750 $self->RosterDBRemove($jid); 2751 } 2752 $self->{DEBUG}->Log3("RosterDBClear: database is empty"); 2753} 2754 2755 2756############################################################################## 2757# 2758# RosterDBExists - allows you to query if the JID exists in the Roster DB. 2759# 2760############################################################################## 2761sub RosterDBExists 2762{ 2763 my $self = shift; 2764 my ($jid) = @_; 2765 2766 if (ref $jid && $jid->isa('Net::XMPP::JID')) 2767 { 2768 $jid = $jid->GetJID(); 2769 } 2770 2771 return unless exists($self->{ROSTERDB}); 2772 return unless exists($self->{ROSTERDB}->{JIDS}); 2773 return unless exists($self->{ROSTERDB}->{JIDS}->{$jid}); 2774 return 1; 2775} 2776 2777 2778############################################################################## 2779# 2780# RosterDBGroupExists - allows you to query if the group exists in the Roster 2781# DB. 2782# 2783############################################################################## 2784sub RosterDBGroupExists 2785{ 2786 my $self = shift; 2787 my ($group) = @_; 2788 2789 return unless exists($self->{ROSTERDB}); 2790 return unless exists($self->{ROSTERDB}->{GROUPS}); 2791 return unless exists($self->{ROSTERDB}->{GROUPS}->{$group}); 2792 return 1; 2793} 2794 2795 2796############################################################################## 2797# 2798# RosterDBGroupJIDs - returns a list of the current groups in your roster. 2799# 2800############################################################################## 2801sub RosterDBGroupJIDs 2802{ 2803 my $self = shift; 2804 my $group = shift; 2805 2806 return unless $self->RosterDBGroupExists($group); 2807 my @jids; 2808 foreach my $jid (keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}})) 2809 { 2810 push(@jids,$self->_jid($jid)); 2811 } 2812 return @jids; 2813} 2814 2815 2816############################################################################## 2817# 2818# RosterDBGroups - returns a list of the current groups in your roster. 2819# 2820############################################################################## 2821sub RosterDBGroups 2822{ 2823 my $self = shift; 2824 2825 return () unless exists($self->{ROSTERDB}->{GROUPS}); 2826 return () if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0); 2827 return keys(%{$self->{ROSTERDB}->{GROUPS}}); 2828} 2829 2830 2831############################################################################## 2832# 2833# RosterDBJIDs - returns a list of all of the JIDs in your roster. 2834# 2835############################################################################## 2836sub RosterDBJIDs 2837{ 2838 my $self = shift; 2839 my $group = shift; 2840 2841 my @jids; 2842 2843 return () unless exists($self->{ROSTERDB}); 2844 return () unless exists($self->{ROSTERDB}->{JIDS}); 2845 foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}})) 2846 { 2847 push(@jids,$self->_jid($jid)); 2848 } 2849 return @jids; 2850} 2851 2852 2853############################################################################## 2854# 2855# RosterDBNonGroupJIDs - returns a list of the JIDs not in a group. 2856# 2857############################################################################## 2858sub RosterDBNonGroupJIDs 2859{ 2860 my $self = shift; 2861 my $group = shift; 2862 2863 my @jids; 2864 2865 return () unless exists($self->{ROSTERDB}); 2866 return () unless exists($self->{ROSTERDB}->{JIDS}); 2867 foreach my $jid (keys(%{$self->{ROSTERDB}->{JIDS}})) 2868 { 2869 next if (exists($self->{ROSTERDB}->{JIDS}->{$jid}->{groups}) && 2870 ($#{$self->{ROSTERDB}->{JIDS}->{$jid}->{groups}} > -1)); 2871 2872 push(@jids,$self->_jid($jid)); 2873 } 2874 return @jids; 2875} 2876 2877 2878############################################################################## 2879# 2880# RosterDBParse - takes an iq packet that containsa roster, parses it, and puts 2881# the roster into the Roster DB. 2882# 2883############################################################################## 2884sub RosterDBParse 2885{ 2886 my $self = shift; 2887 my ($iq) = @_; 2888 2889 #print "RosterDBParse: iq(",$iq->GetXML(),")\n"; 2890 2891 my $type = $iq->GetType(); 2892 return unless (($type eq "set") || ($type eq "result")); 2893 2894 my %newroster = $self->RosterParse($iq); 2895 2896 $self->RosterDBProcessParsed(%newroster); 2897} 2898 2899 2900############################################################################## 2901# 2902# RosterDBProcessParsed - takes a parsed roster and puts it into the Roster DB. 2903# 2904############################################################################## 2905sub RosterDBProcessParsed 2906{ 2907 my $self = shift; 2908 my (%roster) = @_; 2909 2910 foreach my $jid (keys(%roster)) 2911 { 2912 $self->RosterDBRemove($jid); 2913 2914 if ($roster{$jid}->{subscription} ne "remove") 2915 { 2916 $self->RosterDBAdd($jid, %{$roster{$jid}} ); 2917 } 2918 } 2919} 2920 2921 2922############################################################################## 2923# 2924# RosterDBQuery - allows you to get one of the pieces of info from the 2925# Roster DB. 2926# 2927############################################################################## 2928sub RosterDBQuery 2929{ 2930 my $self = shift; 2931 my $jid = shift; 2932 my $key = shift; 2933 2934 if (ref $jid && $jid->isa('Net::XMPP::JID')) 2935 { 2936 $jid = $jid->GetJID(); 2937 } 2938 2939 return unless $self->RosterDBExists($jid); 2940 if (defined($key)) 2941 { 2942 return unless exists($self->{ROSTERDB}->{JIDS}->{$jid}->{$key}); 2943 return $self->{ROSTERDB}->{JIDS}->{$jid}->{$key}; 2944 } 2945 return %{$self->{ROSTERDB}->{JIDS}->{$jid}}; 2946} 2947 2948 2949############################################################################## 2950# 2951# RosterDBRemove - removes the JID from the Roster DB. 2952# 2953############################################################################## 2954sub RosterDBRemove 2955{ 2956 my $self = shift; 2957 my ($jid) = @_; 2958 2959 if ($self->RosterDBExists($jid)) 2960 { 2961 if (defined($self->RosterDBQuery($jid,"groups"))) 2962 { 2963 foreach my $group (@{$self->RosterDBQuery($jid,"groups")}) 2964 { 2965 delete($self->{ROSTERDB}->{GROUPS}->{$group}->{$jid}); 2966 delete($self->{ROSTERDB}->{GROUPS}->{$group}) 2967 if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}->{$group}})) == 0); 2968 delete($self->{ROSTERDB}->{GROUPS}) 2969 if (scalar(keys(%{$self->{ROSTERDB}->{GROUPS}})) == 0); 2970 } 2971 } 2972 2973 delete($self->{ROSTERDB}->{JIDS}->{$jid}); 2974 } 2975} 2976 2977 2978 2979 2980############################################################################## 2981#+---------------------------------------------------------------------------- 2982#| 2983#| TLS Functions 2984#| 2985#+---------------------------------------------------------------------------- 2986############################################################################## 2987 2988############################################################################## 2989# 2990# TLSInit - Initialize the connection for TLS. 2991# 2992############################################################################## 2993sub TLSInit 2994{ 2995 my $self = shift; 2996 2997 $TLS_CALLBACK = sub{ $self->ProcessTLSStanza( @_ ) }; 2998 $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-tls").'"]'=>$TLS_CALLBACK); 2999} 3000 3001 3002############################################################################## 3003# 3004# ProcessTLSStanza - process a TLS based packet. 3005# 3006############################################################################## 3007sub ProcessTLSStanza 3008{ 3009 my $self = shift; 3010 my $sid = shift; 3011 my $node = shift; 3012 3013 my $tag = &XML::Stream::XPath($node,"name()"); 3014 3015 if ($tag eq "failure") 3016 { 3017 $self->TLSClientFailure($node); 3018 } 3019 3020 if ($tag eq "proceed") 3021 { 3022 $self->TLSClientProceed($node); 3023 } 3024} 3025 3026 3027############################################################################## 3028# 3029# TLSStart - client function to have the socket start TLS. 3030# 3031############################################################################## 3032sub TLSStart 3033{ 3034 my $self = shift; 3035 my $timeout = shift; 3036 $timeout = 120 unless defined($timeout); 3037 $timeout = 120 if ($timeout eq ""); 3038 3039 $self->TLSSendStartTLS(); 3040 3041 my $endTime = time + $timeout; 3042 while(!$self->TLSClientDone() && ($endTime >= time)) 3043 { 3044 $self->Process(); 3045 } 3046 3047 if (!$self->TLSClientSecure()) 3048 { 3049 return; 3050 } 3051 3052 $self->RestartStream($timeout); 3053} 3054 3055 3056############################################################################## 3057# 3058# TLSClientProceed - handle a <proceed/> packet. 3059# 3060############################################################################## 3061sub TLSClientProceed 3062{ 3063 my $self = shift; 3064 my $node = shift; 3065 3066 my ($status,$message) = $self->{STREAM}->StartTLS($self->GetStreamID()); 3067 3068 if ($status) 3069 { 3070 $self->{TLS}->{done} = 1; 3071 $self->{TLS}->{secure} = 1; 3072 } 3073 else 3074 { 3075 $self->{TLS}->{done} = 1; 3076 $self->{TLS}->{error} = $message; 3077 } 3078 3079 $self->RemoveDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-tls").'"]'=>$TLS_CALLBACK); 3080} 3081 3082 3083############################################################################## 3084# 3085# TLSClientSecure - return 1 if the socket is secure, 0 otherwise. 3086# 3087############################################################################## 3088sub TLSClientSecure 3089{ 3090 my $self = shift; 3091 3092 return $self->{TLS}->{secure}; 3093} 3094 3095 3096############################################################################## 3097# 3098# TLSClientDone - return 1 if the TLS process is done 3099# 3100############################################################################## 3101sub TLSClientDone 3102{ 3103 my $self = shift; 3104 3105 return $self->{TLS}->{done}; 3106} 3107 3108 3109############################################################################## 3110# 3111# TLSClientError - return the TLS error if any 3112# 3113############################################################################## 3114sub TLSClientError 3115{ 3116 my $self = shift; 3117 3118 return $self->{TLS}->{error}; 3119} 3120 3121 3122############################################################################## 3123# 3124# TLSClientFailure - handle a <failure/> 3125# 3126############################################################################## 3127sub TLSClientFailure 3128{ 3129 my $self = shift; 3130 my $node = shift; 3131 3132 my $type = &XML::Stream::XPath($node,"*/name()"); 3133 3134 $self->{TLS}->{error} = $type; 3135 $self->{TLS}->{done} = 1; 3136} 3137 3138 3139############################################################################## 3140# 3141# TLSSendFailure - Send a <failure/> in the TLS namespace 3142# 3143############################################################################## 3144sub TLSSendFailure 3145{ 3146 my $self = shift; 3147 my $type = shift; 3148 3149 $self->Send("<failure xmlns='".&ConstXMLNS('xmpp-tls')."'><${type}/></failure>"); 3150} 3151 3152 3153############################################################################## 3154# 3155# TLSSendStartTLS - send a <starttls/> in the TLS namespace. 3156# 3157############################################################################## 3158sub TLSSendStartTLS 3159{ 3160 my $self = shift; 3161 3162 $self->Send("<starttls xmlns='".&ConstXMLNS('xmpp-tls')."'/>"); 3163} 3164 3165 3166 3167 3168############################################################################## 3169#+---------------------------------------------------------------------------- 3170#| 3171#| SASL Functions 3172#| 3173#+---------------------------------------------------------------------------- 3174############################################################################## 3175 3176############################################################################## 3177# 3178# SASLInit - Initialize the connection for SASL. 3179# 3180############################################################################## 3181sub SASLInit 3182{ 3183 my $self = shift; 3184 3185 $SASL_CALLBACK = sub{ $self->ProcessSASLStanza( @_ ) }; 3186 $self->SetDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-sasl").'"]'=> $SASL_CALLBACK); 3187} 3188 3189 3190############################################################################## 3191# 3192# ProcessSASLStanza - process a SASL based packet. 3193# 3194############################################################################## 3195sub ProcessSASLStanza 3196{ 3197 my $self = shift; 3198 my $sid = shift; 3199 my $node = shift; 3200 3201 my $tag = &XML::Stream::XPath($node,"name()"); 3202 3203 if ($tag eq "challenge") 3204 { 3205 $self->SASLAnswerChallenge($node); 3206 } 3207 3208 if ($tag eq "failure") 3209 { 3210 $self->SASLClientFailure($node); 3211 } 3212 3213 if ($tag eq "success") 3214 { 3215 $self->SASLClientSuccess($node); 3216 } 3217} 3218 3219 3220############################################################################## 3221# 3222# SASLAnswerChallenge - when we get a <challenge/> we need to do the grunt 3223# work to return a <response/>. 3224# 3225############################################################################## 3226sub SASLAnswerChallenge 3227{ 3228 my $self = shift; 3229 my $node = shift; 3230 3231 my $challenge64 = &XML::Stream::XPath($node,"text()"); 3232 my $challenge = MIME::Base64::decode_base64($challenge64); 3233 3234 my $response = $self->SASLGetClient()->client_step($challenge); 3235 3236 my $response64 = MIME::Base64::encode_base64($response,""); 3237 $self->SASLSendResponse($response64); 3238} 3239 3240 3241############################################################################### 3242# 3243# SASLClient - This is a helper function to perform all of the required steps 3244# for doing SASL with the server. 3245# 3246############################################################################### 3247sub SASLClient 3248{ 3249 my $self = shift; 3250 my $username = shift; 3251 my $password = shift; 3252 3253 my $mechanisms = $self->GetStreamFeature("xmpp-sasl"); 3254 3255 return unless defined($mechanisms); 3256 3257 my $sasl = Authen::SASL->new(mechanism=>join(" ",@{$mechanisms}), 3258 callback=>{ user => $username, 3259 pass => $password 3260 } 3261 ); 3262 3263 $self->{SASL}->{client} = $sasl->client_new(); 3264 $self->{SASL}->{username} = $username; 3265 $self->{SASL}->{password} = $password; 3266 $self->{SASL}->{authed} = 0; 3267 $self->{SASL}->{done} = 0; 3268 3269 $self->SASLSendAuth(); 3270} 3271 3272 3273############################################################################## 3274# 3275# SASLClientAuthed - return 1 if we authed via SASL, 0 otherwise 3276# 3277############################################################################## 3278sub SASLClientAuthed 3279{ 3280 my $self = shift; 3281 3282 return $self->{SASL}->{authed}; 3283} 3284 3285 3286############################################################################## 3287# 3288# SASLClientDone - return 1 if the SASL process is finished 3289# 3290############################################################################## 3291sub SASLClientDone 3292{ 3293 my $self = shift; 3294 3295 return $self->{SASL}->{done}; 3296} 3297 3298 3299############################################################################## 3300# 3301# SASLClientError - return the error if any 3302# 3303############################################################################## 3304sub SASLClientError 3305{ 3306 my $self = shift; 3307 3308 return $self->{SASL}->{error}; 3309} 3310 3311 3312############################################################################## 3313# 3314# SASLClientFailure - handle a received <failure/> 3315# 3316############################################################################## 3317sub SASLClientFailure 3318{ 3319 my $self = shift; 3320 my $node = shift; 3321 3322 my $type = &XML::Stream::XPath($node,"*/name()"); 3323 3324 $self->{SASL}->{error} = $type; 3325 $self->{SASL}->{done} = 1; 3326} 3327 3328 3329############################################################################## 3330# 3331# SASLClientSuccess - handle a received <success/> 3332# 3333############################################################################## 3334sub SASLClientSuccess 3335{ 3336 my $self = shift; 3337 my $node = shift; 3338 3339 $self->{SASL}->{authed} = 1; 3340 $self->{SASL}->{done} = 1; 3341 3342 $self->RemoveDirectXPathCallBacks('/[@xmlns="'.&ConstXMLNS("xmpp-sasl").'"]'=>$SASL_CALLBACK); 3343} 3344 3345 3346############################################################################### 3347# 3348# SASLGetClient - This is a helper function to return the SASL client object. 3349# 3350############################################################################### 3351sub SASLGetClient 3352{ 3353 my $self = shift; 3354 3355 return $self->{SASL}->{client}; 3356} 3357 3358 3359############################################################################## 3360# 3361# SASLSendAuth - send an <auth/> in the SASL namespace 3362# 3363############################################################################## 3364sub SASLSendAuth 3365{ 3366 my $self = shift; 3367 3368 $self->Send("<auth xmlns='".&ConstXMLNS('xmpp-sasl')."' mechanism='".$self->SASLGetClient()->mechanism()."'/>"); 3369} 3370 3371 3372############################################################################## 3373# 3374# SASLSendChallenge - Send a <challenge/> in the SASL namespace 3375# 3376############################################################################## 3377sub SASLSendChallenge 3378{ 3379 my $self = shift; 3380 my $challenge = shift; 3381 3382 $self->Send("<challenge xmlns='".&ConstXMLNS('xmpp-sasl')."'>${challenge}</challenge>"); 3383} 3384 3385 3386############################################################################## 3387# 3388# SASLSendFailure - Send a <failure/> tag in the SASL namespace 3389# 3390############################################################################## 3391sub SASLSendFailure 3392{ 3393 my $self = shift; 3394 my $type = shift; 3395 3396 $self->Send("<failure xmlns='".&ConstXMLNS('xmpp-sasl')."'><${type}/></failure>"); 3397} 3398 3399 3400############################################################################## 3401# 3402# SASLSendResponse - Send a <response/> tag in the SASL namespace 3403# 3404############################################################################## 3405sub SASLSendResponse 3406{ 3407 my $self = shift; 3408 my $response = shift; 3409 3410 $self->Send("<response xmlns='".&ConstXMLNS('xmpp-sasl')."'>${response}</response>"); 3411} 3412 3413 3414 3415 3416############################################################################## 3417#+---------------------------------------------------------------------------- 3418#| 3419#| Default CallBacks 3420#| 3421#+---------------------------------------------------------------------------- 3422############################################################################## 3423 3424 3425############################################################################## 3426# 3427# xmppCallbackInit - initialize the default callbacks 3428# 3429############################################################################## 3430sub xmppCallbackInit 3431{ 3432 my $self = shift; 3433 3434 $self->{DEBUG}->Log1("xmppCallbackInit: start"); 3435 3436 my $weak = $self; 3437 weaken $weak; 3438 $self->SetCallBacks(iq=>sub{ $weak->callbackIQ(@_) }, 3439 presence=>sub{ $weak->callbackPresence(@_) }, 3440 message=>sub{ $weak->callbackMessage(@_) }, 3441 ); 3442 3443 $self->SetPresenceCallBacks(subscribe=>sub{ $weak->callbackPresenceSubscribe(@_) }, 3444 unsubscribe=>sub{ $weak->callbackPresenceUnsubscribe(@_) }, 3445 subscribed=>sub{ $weak->callbackPresenceSubscribed(@_) }, 3446 unsubscribed=>sub{ $weak->callbackPresenceUnsubscribed(@_) }, 3447 ); 3448 3449 $self->TLSInit(); 3450 $self->SASLInit(); 3451 3452 $self->{DEBUG}->Log1("xmppCallbackInit: stop"); 3453} 3454 3455 3456############################################################################## 3457# 3458# callbackMessage - default callback for <message/> packets. 3459# 3460############################################################################## 3461sub callbackMessage 3462{ 3463 my $self = shift; 3464 my $sid = shift; 3465 my $message = shift; 3466 3467 my $type = "normal"; 3468 $type = $message->GetType() if $message->DefinedType(); 3469 3470 $self->{DEBUG}->Log1("callbackMessage: type($type) sid($sid) "); 3471 3472 if (exists($self->{CB}->{Mess}->{$type}) 3473 #&& (ref($self->{CB}->{Mess}->{$type}) =~ /CODE/) 3474 ) 3475 { 3476 &{$self->{CB}->{Mess}->{$type}}($sid,$message); 3477 } 3478 else 3479 { 3480 $self->{DEBUG}->Log1("callbackMessage: type($type) not code (ref($self->{CB}->{Mess}->{$type})) "); 3481 } 3482} 3483 3484 3485############################################################################## 3486# 3487# callbackPresence - default callback for <presence/> packets. 3488# 3489############################################################################## 3490sub callbackPresence 3491{ 3492 my $self = shift; 3493 my $sid = shift; 3494 my $presence = shift; 3495 3496 my $type = "available"; 3497 $type = $presence->GetType() if $presence->DefinedType(); 3498 3499 $self->{DEBUG}->Log1("callbackPresence: type($type) sid($sid) "); 3500 3501 if (exists($self->{CB}->{Pres}->{$type}) 3502# && (ref($self->{CB}->{Pres}->{$type}) =~ /CODE/) 3503 ) 3504 { 3505 &{$self->{CB}->{Pres}->{$type}}($sid,$presence); 3506 } 3507} 3508 3509 3510############################################################################## 3511# 3512# callbackIQ - default callback for <iq/> packets. 3513# 3514############################################################################## 3515sub callbackIQ 3516{ 3517 my $self = shift; 3518 my $sid = shift; 3519 my $iq = shift; 3520 3521 $self->{DEBUG}->Log1("callbackIQ: sid($sid) iq($iq)"); 3522 3523 return unless $iq->DefinedChild(); 3524 my $query = $iq->GetChild(); 3525 return unless defined($query); 3526 3527 my $type = $iq->GetType(); 3528 my $ns = $query->GetXMLNS(); 3529 3530 $self->{DEBUG}->Log1("callbackIQ: type($type) ns($ns)"); 3531 3532 if (exists($self->{CB}->{IQns}->{$ns}) 3533 && (ref($self->{CB}->{IQns}->{$ns}) eq 'HASH' ) 3534 ) 3535 { 3536 $self->{DEBUG}->Log1("callbackIQ: goto user function( $self->{CB}->{IQns}->{$ns} )"); 3537 &{$self->{CB}->{IQns}->{$ns}}($sid,$iq); 3538 3539 } 3540 elsif (exists($self->{CB}->{IQns}->{$ns}->{$type}) 3541# && (ref($self->{CB}->{IQns}->{$ns}->{$type}) =~ /CODE/) 3542 ) 3543 { 3544 $self->{DEBUG}->Log1("callbackIQ: goto user function( $self->{CB}->{IQns}->{$ns}->{$type} )"); 3545 &{$self->{CB}->{IQns}->{$ns}->{$type}}($sid,$iq); 3546 } 3547} 3548 3549 3550############################################################################## 3551# 3552# callbackPresenceSubscribe - default callback for subscribe packets. 3553# 3554############################################################################## 3555sub callbackPresenceSubscribe 3556{ 3557 my $self = shift; 3558 my $sid = shift; 3559 my $presence = shift; 3560 3561 my $reply = $presence->Reply(type=>"subscribed"); 3562 $self->Send($reply,1); 3563 $reply->SetType("subscribe"); 3564 $self->Send($reply,1); 3565} 3566 3567 3568############################################################################## 3569# 3570# callbackPresenceUnsubscribe - default callback for unsubscribe packets. 3571# 3572############################################################################## 3573sub callbackPresenceUnsubscribe 3574{ 3575 my $self = shift; 3576 my $sid = shift; 3577 my $presence = shift; 3578 3579 my $reply = $presence->Reply(type=>"unsubscribed"); 3580 $self->Send($reply,1); 3581} 3582 3583 3584############################################################################## 3585# 3586# callbackPresenceSubscribed - default callback for subscribed packets. 3587# 3588############################################################################## 3589sub callbackPresenceSubscribed 3590{ 3591 my $self = shift; 3592 my $sid = shift; 3593 my $presence = shift; 3594 3595 my $reply = $presence->Reply(type=>"subscribed"); 3596 $self->Send($reply,1); 3597} 3598 3599 3600############################################################################## 3601# 3602# callbackPresenceUnsubscribed - default callback for unsubscribed packets. 3603# 3604############################################################################## 3605sub callbackPresenceUnsubscribed 3606{ 3607 my $self = shift; 3608 my $sid = shift; 3609 my $presence = shift; 3610 3611 my $reply = $presence->Reply(type=>"unsubscribed"); 3612 $self->Send($reply,1); 3613} 3614 3615 3616 3617############################################################################## 3618#+---------------------------------------------------------------------------- 3619#| 3620#| Stream functions 3621#| 3622#+---------------------------------------------------------------------------- 3623############################################################################## 3624sub GetStreamID 3625{ 3626 my $self = shift; 3627 3628 return $self->{SESSION}->{id}; 3629} 3630 3631 3632sub GetStreamFeature 3633{ 3634 my $self = shift; 3635 my $feature = shift; 3636 3637 return $self->{STREAM}->GetStreamFeature($self->GetStreamID(),$feature); 3638} 3639 3640 3641sub RestartStream 3642{ 3643 my $self = shift; 3644 my $timeout = shift; 3645 3646 $self->{SESSION} = 3647 $self->{STREAM}->OpenStream($self->GetStreamID(),$timeout); 3648 return $self->GetStreamID(); 3649} 3650 3651 3652############################################################################## 3653# 3654# ConstXMLNS - Return the namespace from the constant string. 3655# 3656############################################################################## 3657sub ConstXMLNS 3658{ 3659 my $const = shift; 3660 3661 return $XMLNS{$const}; 3662} 3663 3664 36651; 3666