D7net
Home
Console
Upload
information
Create File
Create Folder
About
Tools
:
/
proc
/
self
/
root
/
usr
/
share
/
perl5
/
vendor_perl
/
Net
/
Jabber
/
Filename :
Protocol.pm
back
Copy
############################################################################## # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Library General Public License for more details. # # You should have received a copy of the GNU Library General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Copyright (C) 1998-2004 Jabber Software Foundation http://jabber.org/ # ############################################################################## package Net::Jabber::Protocol; =head1 NAME Net::Jabber::Protocol - Jabber Protocol Library =head1 SYNOPSIS Net::Jabber::Protocol is a module that provides a developer easy access to the Jabber Instant Messaging protocol. It provides high level functions to the Net::Jabber Client, Component, and Server objects. These functions are automatically indluded in those modules through AUTOLOAD and delegates. =head1 DESCRIPTION Protocol.pm seeks to provide enough high level APIs and automation of the low level APIs that writing a Jabber Client/Transport in Perl is trivial. For those that wish to work with the low level you can do that too, but those functions are covered in the documentation for each module. Net::Jabber::Protocol provides functions to login, send and receive messages, set personal information, create a new user account, manage the roster, and disconnect. You can use all or none of the functions, there is no requirement. For more information on how the details for how Net::Jabber is written please see the help for Net::Jabber itself. For more information on writing a Client see Net::Jabber::Client. For more information on writing a Transport see Net::Jabber::Transport. =head2 Modes Several of the functions take a mode argument that let you specify how the function should behave: block - send the packet with an ID, and then block until an answer comes back. You can optionally specify a timeout so that you do not block forever. nonblock - send the packet with an ID, but then return that id and control to the master program. Net::Jabber is still tracking this packet, so you must use the CheckID function to tell when it comes in. (This might not be very useful...) passthru - send the packet with an ID, but do NOT register it with Net::Jabber, then return the ID. This is useful when combined with the XPath function because you can register a one shot function tied to the id you get back. =head2 Basic Functions use Net::Jabber qw( Client ); $Con = new Net::Jabber::Client(); # From $status = $Con->Connect(hostname=>"jabber.org"); # Net::Jabber::Client or use Net::Jabber qw( Component ); $Con = new Net::Jabber::Component(); # $status = $Con->Connect(hostname=>"jabber.org", # From secret=>"bob"); # Net::Jabber::Component # # For callback setup, see Net::XMPP::Protocol # $Con->Info(name=>"Jarl", version=>"v0.6000"); =head2 ID Functions $id = $Con->SendWithID($sendObj); $id = $Con->SendWithID("<tag>XML</tag>"); $receiveObj = $Con->SendAndReceiveWithID($sendObj); $receiveObj = $Con->SendAndReceiveWithID($sendObj, 10); $receiveObj = $Con->SendAndReceiveWithID("<tag>XML</tag>"); $receiveObj = $Con->SendAndReceiveWithID("<tag>XML</tag>", 5); $yesno = $Con->ReceivedID($id); $receiveObj = $Con->GetID($id); $receiveObj = $Con->WaitForID($id); $receiveObj = $Con->WaitForID($id, 20); =head2 IQ Functions =head2 Agents Functions %agents = $Con->AgentsGet(); %agents = $Con->AgentsGet(to=>"transport.jabber.org"); =head2 Browse Functions %hash = $Con->BrowseRequest(jid=>"jabber.org"); %hash = $Con->BrowseRequest(jid=>"jabber.org", timeout=>10); $id = $Con->BrowseRequest(jid=>"jabber.org", mode=>"nonblock"); $id = $Con->BrowseRequest(jid=>"jabber.org", mode=>"passthru"); =head2 Browse DB Functions $Con->BrowseDBDelete("jabber.org"); $Con->BrowseDBDelete(Net::Jabber::JID); $presence = $Con->BrowseDBQuery(jid=>"bob\@jabber.org"); $presence = $Con->BrowseDBQuery(jid=>Net::Jabber::JID); $presence = $Con->BrowseDBQuery(jid=>"users.jabber.org", timeout=>10); $presence = $Con->BrowseDBQuery(jid=>"conference.jabber.org", refresh=>1); =head2 Bystreams Functions %hash = $Con->ByteStreamsProxyRequest(jid=>"proxy.server"); %hash = $Con->ByteStreamsProxyRequest(jid=>"proxy.server", timeout=>10); $id = $Con->ByteStreamsProxyRequest(jid=>"proxy.server", mode=>"nonblock"); $id = $Con->ByteStreamsProxyRequest(jid=>"proxy.server", mode=>"passthru"); %hash = $Con->ByteStreamsProxyParse($query); $status = $Con->ByteStreamsProxyActivate(sid=>"stream_id", jid=>"proxy.server"); $status = $Con->ByteStreamsProxyActivate(sid=>"stream_id", jid=>"proxy.server", timeout=>10); $id = $Con->ByteStreamsProxyActivate(sid=>"stream_id", jid=>"proxy.server", mode=>"nonblock"); $id = $Con->ByteStreamsProxyActivate(sid=>"stream_id", jid=>"proxy.server", mode=>"passthru"); $jid = $Con->ByteStreamsOffer(sid=>"stream_id", streamhosts=>[{jid=>"jid", host=>"host", port=>"port", zeroconf=>"zero", }, ... ], jid=>"bob\@jabber.org"); $jid = $Con->ByteStreamsOffer(sid=>"stream_id", streamhosts=>[{},{},...], jid=>"bob\@jabber.org", timeout=>10); $id = $Con->ByteStreamsOffer(sid=>"stream_id", streamhosts=>[{},{},...], jid=>"bob\@jabber.org", mode=>"nonblock"); $id = $Con->ByteStreamsOffer(sid=>"stream_id", streamhosts=>[{},{},...], jid=>"bob\@jabber.org", mode=>"passthru"); =head2 Disco Functions %hash = $Con->DiscoInfoRequest(jid=>"jabber.org"); %hash = $Con->DiscoInfoRequest(jid=>"jabber.org", node=>"node..."); %hash = $Con->DiscoInfoRequest(jid=>"jabber.org", node=>"node...", timeout=>10); $id = $Con->DiscoInfoRequest(jid=>"jabber.org", mode=>"nonblock"); $id = $Con->DiscoInfoRequest(jid=>"jabber.org", node=>"node...", mode=>"nonblock"); $id = $Con->DiscoInfoRequest(jid=>"jabber.org", mode=>"passthru"); $id = $Con->DiscoInfoRequest(jid=>"jabber.org", node=>"node...", mode=>"passthru"); %hash = $Con->DiscoInfoParse($query); %hash = $Con->DiscoItemsRequest(jid=>"jabber.org"); %hash = $Con->DiscoItemsRequest(jid=>"jabber.org", timeout=>10); $id = $Con->DiscoItemsRequest(jid=>"jabber.org", mode=>"nonblock"); $id = $Con->DiscoItemsRequest(jid=>"jabber.org", mode=>"passthru"); %hash = $Con->DiscoItemsParse($query); =head2 Feature Negotiation Functions %hash = $Con->FeatureNegRequest(jid=>"jabber.org", features=>{ feat1=>["opt1","opt2",...], feat2=>["optA","optB",...] } ); %hash = $Con->FeatureNegRequest(jid=>"jabber.org", features=>{ ... }, timeout=>10); $id = $Con->FeatureNegRequest(jid=>"jabber.org", features=>{ ... }, mode=>"nonblock"); $id = $Con->FeatureNegRequest(jid=>"jabber.org", features=>{ ... }, mode=>"passthru"); my $query = $self->FeatureNegQuery(\{ ... }); $iq->AddQuery($query); %hash = $Con->FeatureNegParse($query); =head2 File Transfer Functions $method = $Con->FileTransferOffer(jid=>"bob\@jabber.org", sid=>"stream_id", filename=>"/path/to/file", methods=>["http://jabber.org/protocol/si/profile/bytestreams", "jabber:iq:oob", ... ] ); $method = $Con->FileTransferOffer(jid=>"bob\@jabber.org", sid=>"stream_id", filename=>"/path/to/file", methods=>\@methods, timeout=>"10"); $id = $Con->FileTransferOffer(jid=>"bob\@jabber.org", sid=>"stream_id", filename=>"/path/to/file", methods=>\@methods, mode=>"nonblock"); $id = $Con->FileTransferOffer(jid=>"bob\@jabber.org", sid=>"stream_id", filename=>"/path/to/file", methods=>\@methods, mode=>"passthru"); =head2 Last Functions $Con->LastQuery(); $Con->LastQuery(to=>"bob@jabber.org"); %result = $Con->LastQuery(mode=>"block"); %result = $Con->LastQuery(to=>"bob@jabber.org", mode=>"block"); %result = $Con->LastQuery(to=>"bob@jabber.org", mode=>"block", timeout=>10); %result = $Con->LastQuery(mode=>"block", timeout=>10); $Con->LastSend(to=>"bob@jabber.org"); $seconds = $Con->LastActivity(); =head2 Multi-User Chat Functions $Con->MUCJoin(room=>"jabber", server=>"conference.jabber.org", nick=>"nick"); $Con->MUCJoin(room=>"jabber", server=>"conference.jabber.org", nick=>"nick", password=>"secret"); =head2 Register Functions @result = $Con->RegisterSendData("users.jabber.org", first=>"Bob", last=>"Smith", nick=>"bob", email=>"foo@bar.net"); =head2 RPC Functions $query = $Con->RPCEncode(type=>"methodCall", methodName=>"methodName", params=>[param,param,...]); $query = $Con->RPCEncode(type=>"methodResponse", params=>[param,param,...]); $query = $Con->RPCEncode(type=>"methodResponse", faultCode=>4, faultString=>"Too many params"); @response = $Con->RPCParse($iq); @response = $Con->RPCCall(to=>"dataHouse.jabber.org", methodname=>"numUsers", params=>[ param,param,... ] ); $Con->RPCResponse(to=>"you\@jabber.org", params=>[ param,param,... ]); $Con->RPCResponse(to=>"you\@jabber.org", faultCode=>"4", faultString=>"Too many parameters" ); $Con->RPCSetCallBacks(myMethodA=>\&methoda, myMethodB=>\&do_somthing, etc... ); =head2 Search Functions %fields = $Con->SearchRequest(); %fields = $Con->SearchRequest(to=>"users.jabber.org"); %fields = $Con->SearchRequest(to=>"users.jabber.org", timeout=>10); $Con->SearchSend(to=>"somewhere", name=>"", first=>"Bob", last=>"", nick=>"bob", email=>"", key=>"some key"); $Con->SearchSendData("users.jabber.org", first=>"Bob", last=>"", nick=>"bob", email=>""); =head2 Time Functions $Con->TimeQuery(); $Con->TimeQuery(to=>"bob@jabber.org"); %result = $Con->TimeQuery(mode=>"block"); %result = $Con->TimeQuery(to=>"bob@jabber.org", mode=>"block"); $Con->TimeSend(to=>"bob@jabber.org"); =head2 Version Functions $Con->VersionQuery(); $Con->VersionQuery(to=>"bob@jabber.org"); %result = $Con->VersionQuery(mode=>"block"); %result = $Con->VersionQuery(to=>"bob@jabber.org", mode=>"block"); $Con->VersionSend(to=>"bob@jabber.org", name=>"Net::Jabber", ver=>"1.0a", os=>"Perl"); =head1 METHODS =head2 Basic Functions Info(name=>string, - Set some information so that Net::Jabber version=>string) can auto-reply to some packets for you to reduce the work you have to do. NOTE: This requires that you use the SetIQCallBacks methodology and not the SetCallBacks for <iq/> packets. =head2 IQ Functions =head2 Agents Functions ******************************** * * * Deprecated in favor of Disco * * * ******************************** AgentsGet(to=>string, - takes all of the information and AgentsGet() builds a Net::Jabber::IQ::Agents packet. It then sends that packet either to the server, or to the specified transport, with an ID and waits for that ID to return. Then it looks in the resulting packet and builds a hash that contains the values of the agent list. The hash is layed out like this: (NOTE: the jid is the key to distinguish the various agents) $hash{<JID>}->{order} = 4 ->{name} = "ICQ Transport" ->{transport} = "ICQ #" ->{description} = "ICQ..blah.." ->{service} = "icq" ->{register} = 1 ->{search} = 1 etc... The order field determines the order that it came from the server in... in case you care. For more info on the valid fields see the Net::Jabber::Query jabber:iq:agent namespace. =head2 Browse Functions ******************************** * * * Deprecated in favor of Disco * * * ******************************** BrowseRequest(jid=>string, - sends a jabber:iq:browse request to mode=>string, the jid passed as an argument. timeout=>int) Returns a hash with the resulting tree if mode is set to "block": $browse{'category'} = "conference" $browse{'children'}->[0] $browse{'children'}->[1] $browse{'children'}->[11] $browse{'jid'} = "conference.jabber.org" $browse{'name'} = "Jabber.org Conferencing Center" $browse{'ns'}->[0] $browse{'ns'}->[1] $browse{'type'} = "public" The ns array is an array of the namespaces that this jid supports. The children array points to hashs of this form, and represent the fact that they can be browsed to. See MODES above for using the mode and timeout. =head2 Browse DB Functions BrowseDBDelete(string|Net::Jabber::JID) - delete thes JID browse data from the DB. BrowseDBQuery(jid=>string | NJ::JID, - returns the browse data timeout=>integer, for the requested JID. If refresh=>0|1) the DB does not contain the data for the JID, then it attempts to fetch the data via BrowseRequest(). The timeout is passed to the BrowseRequest() call, and refresh tells the DB to request the data, even if it already has some. =head2 Bytestreams Functions ByteStreamsProxyRequest(jid=>string, - sends a bytestreams request mode=>string, to the jid passed as an timeout=>int) argument. Returns an array ref with the resulting tree if mode is set to "block". See ByteStreamsProxyParse for the format of the resulting tree. See MODES above for using the mode and timeout. ByteStreamsProxyParse(Net::Jabber::Query) - parses the query and returns an array ref to the resulting tree: $host[0]->{jid} = "bytestreams1.proxy.server"; $host[0]->{host} = "proxy1.server"; $host[0]->{port} = "5006"; $host[1]->{jid} = "bytestreams2.proxy.server"; $host[1]->{host} = "proxy2.server"; $host[1]->{port} = "5007"; ... ByteStreamsProxyActivate(jid=>string, - sends a bytestreams activate sid=>string, to the jid passed as an mode=>string, argument. Returns 1 if the timeout=>int) proxy activated (undef if it did not) if mode is set to "block". sid is the stream id that is being used to talk about this stream. See MODES above for using the mode and timeout. ByteStreamsOffer(jid=>string, - sends a bytestreams offer sid=>string, to the jid passed as an streamhosts=>arrayref argument. Returns the jid mode=>string, of the streamhost that the timeout=>int) user selected if mode is set to "block". streamhosts is the same format as the array ref returned from ByteStreamsProxyParse. See MODES above for using the mode and timeout. =head2 Disco Functions DiscoInfoRequest(jid=>string, - sends a disco#info request to node=>string, the jid passed as an argument, mode=>string, and the node if specified. timeout=>int) Returns a hash with the resulting tree if mode is set to "block". See DiscoInfoParse for the format of the resulting tree. See MODES above for using the mode and timeout. DiscoInfoParse(Net::Jabber::Query) - parses the query and returns a hash ref to the resulting tree: $info{identity}->[0]->{category} = "groupchat"; $info{identity}->[0]->{name} = "Public Chatrooms"; $info{identity}->[0]->{type} = "public"; $info{identity}->[1]->{category} = "groupchat"; $info{identity}->[1]->{name} = "Private Chatrooms"; $info{identity}->[1]->{type} = "private"; $info{feature}->{http://jabber.org/protocol/disco#info} = 1; $info{feature}->{http://jabber.org/protocol/muc#admin} = 1; DiscoItemsRequest(jid=>string, - sends a disco#items request to mode=>string, the jid passed as an argument. timeout=>int) Returns a hash with the resulting tree if mode is set to "block". See DiscoItemsParse for the format of the resulting tree. See MODES above for using the mode and timeout. DiscoItemsParse(Net::Jabber::Query) - parses the query and returns a hash ref to the resulting tree: $items{jid}->{node} = name; $items{"proxy.server"}->{""} = "Bytestream Proxy Server"; $items{"conf.server"}->{"public"} = "Public Chatrooms"; $items{"conf.server"}->{"private"} = "Private Chatrooms"; =head2 Feature Negotiation Functions FeatureNegRequest(jid=>string, - sends a feature negotiation to features=>hash ref, the jid passed as an argument, mode=>string, using the features specified. timeout=>int) Returns a hash with the resulting tree if mode is set to "block". See DiscoInfoQuery for the format of the features hash ref. See DiscoInfoParse for the format of the resulting tree. See MODES above for using the mode and timeout. FeatureNegParse(Net::Jabber::Query) - parses the query and returns a hash ref to the resulting tree: $features->{feat1} = ["opt1","opt2",...]; $features->{feat2} = ["optA","optB",...]; .... If this is a result: $features->{feat1} = "opt2"; $features->{feat2} = "optA"; .... FeatureNeqQuery(hash ref) - takes a hash ref and turns it into a feature negotiation query that you can AddQuery into your packaet. The format of the hash ref is as follows: $features->{feat1} = ["opt1","opt2",...]; $features->{feat2} = ["optA","optB",...]; .... =head2 File Transfer Functions FileTransferOffer(jid=>string, - sends a file transfer stream sid=>string, initiation to the jid passed filename=>string, as an argument. Returns the mode=>string, method (if the users accepts), timeout=>int) undef (if the user declines), if the mode is set to "block". See MODES above for using the mode and timeout. =head2 Last Functions LastQuery(to=>string, - asks the jid specified for its last mode=>string, activity. If the to is blank, then it timeout=>int) queries the server. Returns a hash with LastQuery() the various items set if mode is set to "block": $last{seconds} - Seconds since activity $last{message} - Message for activity See MODES above for using the mode and timeout. LastSend(to=>string, - sends the specified last to the specified jid. hash) the hash is the seconds and message as shown in the Net::Jabber::Query man page. LastActivity() - returns the number of seconds since the last activity by the user. =head2 Multi-User Chat Functions MUCJoin(room=>string, - Sends the appropriate MUC protocol to join server=>string, the specified room with the specified nick. nick=>string, password=>string) =head2 Register Functions RegisterSendData(string|JID, - takes the contents of the hash and hash) builds a jabebr:x:data return packet which it sends in a Net::Jabber::Query jabber:iq:register namespace packet. The first argument is the JID to send the packet to. This function returns an array that looks like this: [ type , message ] If type is "ok" then registration was successful, otherwise message contains a little more detail about the error. =head2 RPC Functions RPCParse(IQ object) - returns an array. The first argument tells the status "ok" or "fault". The second argument is an array if "ok", or a hash if "fault". RPCCall(to=>jid|string, - takes the methodName and params, methodName=>string, builds the RPC calls and sends it params=>array, to the specified address. Returns mode=>string, the above data from RPCParse. timeout=>int) See MODES above for using the mode and timeout. RPCResponse(to=>jid|string, - generates a response back to params=>array, the caller. If any part of faultCode=>int, fault is specified, then it faultString=>string) wins. Note: To ensure that you get the correct type for a param sent back, you can specify the type by prepending the type to the value: "i4:5" or "int:5" "boolean:0" "string:56" "double:5.0" "datetime:20020415T11:11:11" "base64:...." RPCSetCallBacks(method=>function, - sets the callback functions method=>function, for the specified methods. etc...) The method comes from the <methodName/> and is case sensitive. The single arguemnt is a ref to an array that contains the <params/>. The function you write should return one of two things: ["ok", [...] ] The [...] is a list of the <params/> you want to return. ["fault", {faultCode=>1, faultString=>...} ] If you set the function to undef, then the method is removed from the list. =head2 Search Functions SearchRequest(to=>string, - send an <iq/> request to the specified mode=>string, server/transport, if not specified it timeout=>int) sends to the current active server. SearchRequest() The function returns a hash that contains the required fields. Here is an example of the hash: $hash{fields} - The raw fields from the iq:register. To be used if there is no x:data in the packet. $hash{instructions} - How to fill out the form. $hash{form} - The new dynamic forms. In $hash{form}, the fields that are present are the required fields the server needs. See MODES above for using the mode and timeout. SearchSend(to=>string|JID, - takes the contents of the hash and hash) passes it to the SetSearch function in the Net::Jabber::Query jabber:iq:search namespace. And then sends the packet. SearchSendData(string|JID, - takes the contents of the hash and hash) builds a jabebr:x:data return packet which it sends in a Net::Jabber::Query jabber:iq:search namespace packet. The first argument is the JID to send the packet to. =head2 Time Functions TimeQuery(to=>string, - asks the jid specified for its localtime. mode=>string, If the to is blank, then it queries the timeout=>int) server. Returns a hash with the various TimeQuery() items set if mode is set to "block": $time{utc} - Time in UTC $time{tz} - Timezone $time{display} - Display string See MODES above for using the mode and timeout. TimeSend(to=>string) - sends the current UTC time to the specified jid. =head2 Version Functions VersionQuery(to=>string, - asks the jid specified for its mode=>string, client version information. If the timeout=>int) to is blank, then it queries the VersionQuery() server. Returns ahash with the various items set if mode is set to "block": $version{name} - Name $version{ver} - Version $version{os} - Operating System/ Platform See MODES above for using the mode and timeout. VersionSend(to=>string, - sends the specified version information name=>string, to the jid specified in the to. ver=>string, os=>string) =head1 AUTHOR Ryan Eatmon =head1 COPYRIGHT This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use Carp; use vars qw($VERSION); $VERSION = "2.0"; ############################################################################## # BuildObject takes a root tag and builds the correct object. NEWOBJECT is # the table that maps tag to package. Override these, or provide new ones. #----------------------------------------------------------------------------- $Net::XMPP::Protocol::NEWOBJECT{'iq'} = "Net::Jabber::IQ"; $Net::XMPP::Protocol::NEWOBJECT{'message'} = "Net::Jabber::Message"; $Net::XMPP::Protocol::NEWOBJECT{'presence'} = "Net::Jabber::Presence"; $Net::XMPP::Protocol::NEWOBJECT{'jid'} = "Net::Jabber::JID"; ############################################################################## ############################################################################### #+----------------------------------------------------------------------------- #| #| Base API #| #+----------------------------------------------------------------------------- ############################################################################### ############################################################################### # # Info - set the base information about this Jabber Client/Component for # use in a default response. # ############################################################################### sub Info { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } foreach my $arg (keys(%args)) { $self->{INFO}->{$arg} = $args{$arg}; } } ############################################################################### # # DefineNamespace - adds the namespace and corresponding functions onto the # of available functions based on namespace. # # Deprecated in favor of AddNamespace # ############################################################################### sub DefineNamespace { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } croak("You must specify xmlns=>'' for the function call to DefineNamespace") if !exists($args{xmlns}); croak("You must specify type=>'' for the function call to DefineNamespace") if !exists($args{type}); croak("You must specify functions=>'' for the function call to DefineNamespace") if !exists($args{functions}); my %xpath; my $tag; if (exists($args{tag})) { $tag = $args{tag}; } else { $tag = "x" if ($args{type} eq "X"); $tag = "query" if ($args{type} eq "Query"); } foreach my $function (@{$args{functions}}) { my %tempHash = %{$function}; my %funcHash; foreach my $func (keys(%tempHash)) { $funcHash{lc($func)} = $tempHash{$func}; } croak("You must specify name=>'' for each function in call to DefineNamespace") if !exists($funcHash{name}); my $name = delete($funcHash{name}); if (!exists($funcHash{set}) && exists($funcHash{get})) { croak("The DefineNamespace arugments have changed, and I cannot determine the\nnew values automatically for name($name). Please read the man page\nfor Net::Jabber::Namespaces. I apologize for this incompatability.\n"); } if (exists($funcHash{type}) || exists($funcHash{path}) || exists($funcHash{child}) || exists($funcHash{calls})) { foreach my $type (keys(%funcHash)) { if ($type eq "child") { $xpath{$name}->{$type}->{ns} = $funcHash{$type}->[1]; my $i = 2; while( $i <= $#{$funcHash{$type}} ) { if ($funcHash{$type}->[$i] eq "__netjabber__:skip_xmlns") { $xpath{$name}->{$type}->{skip_xmlns} = 1; } if ($funcHash{$type}->[$i] eq "__netjabber__:specifyname") { $xpath{$name}->{$type}->{specify_name} = 1; $i++; $xpath{$name}->{$type}->{tag} = $funcHash{$type}->[$i+1]; } $i++; } } else { $xpath{$name}->{$type} = $funcHash{$type}; } } next; } my $type = $funcHash{set}->[0]; my $xpath = $funcHash{set}->[1]; if (exists($funcHash{hash})) { $xpath = "text()" if ($funcHash{hash} eq "data"); $xpath .= "/text()" if ($funcHash{hash} eq "child-data"); $xpath = "\@$xpath" if ($funcHash{hash} eq "att"); $xpath = "$1/\@$2" if ($funcHash{hash} =~ /^att-(\S+)-(.+)$/); } if ($type eq "master") { $xpath{$name}->{type} = $type; next; } if ($type eq "scalar") { $xpath{$name}->{path} = $xpath; next; } if ($type eq "flag") { $xpath{$name}->{type} = 'flag'; $xpath{$name}->{path} = $xpath; next; } if (($funcHash{hash} eq "child-add") && exists($funcHash{add})) { $xpath{$name}->{type} = "node"; $xpath{$name}->{path} = $funcHash{add}->[3]; $xpath{$name}->{child}->{ns} = $funcHash{add}->[1]; $xpath{$name}->{calls} = [ 'Add' ]; next; } } $self->AddNamespace(ns => $args{xmlns}, tag => $tag, xpath => \%xpath ); } ############################################################################### # # AgentsGet - Sends an empty IQ to the server/transport to request that the # list of supported Agents be sent to them. Returns a hash # containing the values for the agents. # ############################################################################### sub AgentsGet { my $self = shift; my $iq = $self->_iq(); $iq->SetIQ(@_); $iq->SetIQ(type=>"get"); my $query = $iq->NewQuery("jabber:iq:agents"); $iq = $self->SendAndReceiveWithID($iq); return unless defined($iq); $query = $iq->GetQuery(); my @agents = $query->GetAgents(); my %agents; my $count = 0; foreach my $agent (@agents) { my $jid = $agent->GetJID(); $agents{$jid}->{name} = $agent->GetName(); $agents{$jid}->{description} = $agent->GetDescription(); $agents{$jid}->{transport} = $agent->GetTransport(); $agents{$jid}->{service} = $agent->GetService(); $agents{$jid}->{register} = $agent->DefinedRegister(); $agents{$jid}->{search} = $agent->DefinedSearch(); $agents{$jid}->{groupchat} = $agent->DefinedGroupChat(); $agents{$jid}->{agents} = $agent->DefinedAgents(); $agents{$jid}->{order} = $count++; } return %agents; } ############################################################################### # # BrowseRequest - requests the browse information from the specified JID. # ############################################################################### sub BrowseRequest { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>$args{jid}, type=>"get"); my $query = $iq->NewQuery("jabber:iq:browse"); #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); #-------------------------------------------------------------------------- # Check if there was an error. #-------------------------------------------------------------------------- return unless defined($iq); if ($iq->GetType() eq "error") { $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); return; } $query = $iq->GetQuery(); if (defined($query)) { my %browse = %{$self->BrowseParse($query)}; return %browse; } else { return; } } ############################################################################### # # BrowseParse - helper function for BrowseRequest to convert the object # tree into a hash for better consumption. # ############################################################################### sub BrowseParse { my $self = shift; my $item = shift; my %browse; if ($item->DefinedCategory()) { $browse{category} = $item->GetCategory(); } else { $browse{category} = $item->GetTag(); } $browse{type} = $item->GetType(); $browse{name} = $item->GetName(); $browse{jid} = $item->GetJID(); $browse{ns} = [ $item->GetNS() ]; foreach my $subitem ($item->GetItems()) { my ($subbrowse) = $self->BrowseParse($subitem); push(@{$browse{children}},$subbrowse); } return \%browse; } ############################################################################### # # BrowseDBDelete - delete the JID from the DB completely. # ############################################################################### sub BrowseDBDelete { my $self = shift; my ($jid) = @_; my $indexJID = $jid; $indexJID = $jid->GetJID() if (ref($jid) eq "Net::Jabber::JID"); return if !exists($self->{BROWSEDB}->{$indexJID}); delete($self->{BROWSEDB}->{$indexJID}); $self->{DEBUG}->Log1("BrowseDBDelete: delete ",$indexJID," from the DB"); } ############################################################################### # # BrowseDBQuery - retrieve the last Net::Jabber::Browse received with # the highest priority. # ############################################################################### sub BrowseDBQuery { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $args{timeout} = 10 unless exists($args{timeout}); my $indexJID = $args{jid}; $indexJID = $args{jid}->GetJID() if (ref($args{jid}) eq "Net::Jabber::JID"); if ((exists($args{refresh}) && ($args{refresh} eq "1")) || (!exists($self->{BROWSEDB}->{$indexJID}))) { my %browse = $self->BrowseRequest(jid=>$args{jid}, timeout=>$args{timeout}); $self->{BROWSEDB}->{$indexJID} = \%browse; } return %{$self->{BROWSEDB}->{$indexJID}}; } ############################################################################### # # ByteStreamsProxyRequest - This queries a proxy server to get a list of # ############################################################################### sub ByteStreamsProxyRequest { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>$args{jid}, type=>"get"); my $query = $iq->NewQuery("http://jabber.org/protocol/bytestreams"); #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); #-------------------------------------------------------------------------- # Check if there was an error. #-------------------------------------------------------------------------- return unless defined($iq); if ($iq->GetType() eq "error") { $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); return; } $query = $iq->GetQuery(); if (defined($query)) { my @hosts = @{$self->ByteStreamsProxyParse($query)}; return @hosts; } else { return; } } ############################################################################### # # ByteStreamsProxyParse - helper function for ByteStreamProxyRequest to convert # the object tree into a hash for better consumption. # ############################################################################### sub ByteStreamsProxyParse { my $self = shift; my $item = shift; my @hosts; foreach my $host ($item->GetStreamHosts()) { my %host; $host{jid} = $host->GetJID(); $host{host} = $host->GetHost() if $host->DefinedHost(); $host{port} = $host->GetPort() if $host->DefinedPort(); $host{zeroconf} = $host->GetZeroConf() if $host->DefinedZeroConf(); push(@hosts,\%host); } return \@hosts; } ############################################################################### # # ByteStreamsProxyActivate - This tells a proxy to activate the connection # ############################################################################### sub ByteStreamsProxyActivate { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>$args{jid}, type=>"set"); my $query = $iq->NewQuery("http://jabber.org/protocol/bytestreams"); $query->SetByteStreams(sid=>$args{sid}, activate=>(ref($args{recipient}) eq "Net::Jabber::JID" ? $args{recipient}->GetJID("full") : $args{recipient}) ); #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); #-------------------------------------------------------------------------- # Check if there was an error. #-------------------------------------------------------------------------- return unless defined($iq); if ($iq->GetType() eq "error") { $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); return; } return 1; } ############################################################################### # # ByteStreamsOffer - This offers a recipient a list of stream hosts to pick # from. # ############################################################################### sub ByteStreamsOffer { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>$args{jid}, type=>"set"); my $query = $iq->NewQuery("http://jabber.org/protocol/bytestreams"); $query->SetByteStreams(sid=>$args{sid}); foreach my $host (@{$args{streamhosts}}) { $query->AddStreamHost(jid=>$host->{jid}, (exists($host->{host}) ? (host=>$host->{host}) : ()), (exists($host->{port}) ? (port=>$host->{port}) : ()), (exists($host->{zeroconf}) ? (zeroconf=>$host->{zeroconf}) : ()), ); } #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); #-------------------------------------------------------------------------- # Check if there was an error. #-------------------------------------------------------------------------- return unless defined($iq); if ($iq->GetType() eq "error") { $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); return; } $query = $iq->GetQuery(); if (defined($query)) { return $query->GetStreamHostUsedJID(); } else { return; } } ############################################################################### # # DiscoInfoRequest - requests the disco information from the specified JID. # ############################################################################### sub DiscoInfoRequest { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>$args{jid}, type=>"get"); my $query = $iq->NewQuery("http://jabber.org/protocol/disco#info"); $query->SetDiscoInfo(node=>$args{node}) if exists($args{node}); #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); #-------------------------------------------------------------------------- # Check if there was an error. #-------------------------------------------------------------------------- return unless defined($iq); if ($iq->GetType() eq "error") { $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); return; } return unless $iq->DefinedQuery(); $query = $iq->GetQuery(); return %{$self->DiscoInfoParse($query)}; } ############################################################################### # # DiscoInfoParse - helper function for DiscoInfoRequest to convert the object # tree into a hash for better consumption. # ############################################################################### sub DiscoInfoParse { my $self = shift; my $item = shift; my %disco; foreach my $ident ($item->GetIdentities()) { my %identity; $identity{category} = $ident->GetCategory(); $identity{name} = $ident->GetName(); $identity{type} = $ident->GetType(); push(@{$disco{identity}},\%identity); } foreach my $feat ($item->GetFeatures()) { $disco{feature}->{$feat->GetVar()} = 1; } return \%disco; } ############################################################################### # # DiscoItemsRequest - requests the disco information from the specified JID. # ############################################################################### sub DiscoItemsRequest { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>$args{jid}, type=>"get"); my $query = $iq->NewQuery("http://jabber.org/protocol/disco#items"); $query->SetDiscoItems(node=>$args{node}) if exists($args{node}); #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); #-------------------------------------------------------------------------- # Check if there was an error. #-------------------------------------------------------------------------- return unless defined($iq); if ($iq->GetType() eq "error") { $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); return; } $query = $iq->GetQuery(); if (defined($query)) { my %disco = %{$self->DiscoItemsParse($query)}; return %disco; } else { return; } } ############################################################################### # # DiscoItemsParse - helper function for DiscoItemsRequest to convert the object # tree into a hash for better consumption. # ############################################################################### sub DiscoItemsParse { my $self = shift; my $item = shift; my %disco; foreach my $item ($item->GetItems()) { $disco{$item->GetJID()}->{$item->GetNode()} = $item->GetName(); } return \%disco; } ############################################################################### # # FeatureNegRequest - requests a feature negotiation from the specified JID. # ############################################################################### sub FeatureNegRequest { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>$args{jid}, type=>"get"); my $query = $self->FeatureNegQuery($args{features}); $iq->AddQuery($query); #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); #-------------------------------------------------------------------------- # Check if there was an error. #-------------------------------------------------------------------------- return unless defined($iq); if ($iq->GetType() eq "error") { $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); return; } $query = $iq->GetQuery(); if (defined($query)) { my %feats = %{$self->FeatureNegParse($query)}; return %feats; } else { return; } } #xxx fneg needs to reutrn a type='submit' on the x:data in a result ############################################################################### # # FeatureNegQuery - given a feature hash, return a query that contains it. # ############################################################################### sub FeatureNegQuery { my $self = shift; my $features = shift; my $tag = "query"; $tag = $Net::Jabber::Query::TAGS{'http://jabber.org/protocol/feature-neg'} if exists($Net::Jabber::Query::TAGS{'http://jabber.org/protocol/feature-neg'}); my $query = new Net::Jabber::Query($tag); $query->SetXMLNS("http://jabber.org/protocol/feature-neg"); my $xdata = $query->NewX("jabber:x:data"); foreach my $feature (keys(%{$features})) { my $field = $xdata->AddField(type=>"list-single", var=>$feature); foreach my $value (@{$features->{$feature}}) { $field->AddOption(value=>$value); } } return $query; } ############################################################################### # # FeatureNegParse - helper function for FeatureNegRequest to convert the object # tree into a hash for better consumption. # ############################################################################### sub FeatureNegParse { my $self = shift; my $item = shift; my %feats; my $xdata = $item->GetX("jabber:x:data"); foreach my $field ($xdata->GetFields()) { my @options; foreach my $option ($field->GetOptions()) { push(@options,$option->GetValue()); } if ($#options == -1) { $feats{$field->GetVar()} = $field->GetValue(); } else { $feats{$field->GetVar()} = \@options; } } return \%feats; } #XXX - need a feature-neg answer function... ############################################################################### # # FileTransferOffer - offer a file transfer JEP-95 # ############################################################################### sub FileTransferOffer { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>$args{jid}, type=>"set"); my $query = $iq->NewQuery("http://jabber.org/protocol/si"); my $profile = $query->NewQuery("http://jabber.org/protocol/si/profile/file-transfer"); # XXX support hashing via MD5 # XXX support date via JEP-82 my ($filename) = ($args{filename} =~ /\/?([^\/]+)$/); $profile->SetFile(name=>$filename, size=>(-s $args{filename}) ); $profile->SetFile(desc=>$args{desc}) if exists($args{desc}); $query->SetStream(mimetype=>(-B $args{filename} ? "application/octect-stream" : "text/plain" ), id=>$args{sid}, profile=>"http://jabber.org/protocol/si/profile/file-transfer" ); if (!exists($args{skip_methods})) { if ($#{$args{methods}} == -1) { print STDERR "You did not provide any valid methods for file transfer.\n"; return; } my $fneg = $self->FeatureNegQuery({'stream-method'=>$args{methods}}); $query->AddQuery($fneg); } #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); #-------------------------------------------------------------------------- # Check if there was an error. #-------------------------------------------------------------------------- return unless defined($iq); if ($iq->GetType() eq "error") { $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); return; } $query = $iq->GetQuery(); if (defined($query)) { my @fneg = $query->GetQuery("http://jabber.org/protocol/feature-neg"); my @xdata = $fneg[0]->GetX("jabber:x:data"); my @fields = $xdata[0]->GetFields(); return $fields[0]->GetValue(); # XXX need better error handling } else { return; } } ############################################################################### # # TreeTransferOffer - offer a file transfer JEP-95 # ############################################################################### sub TreeTransferOffer { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>$args{jid}, type=>"set"); my $query = $iq->NewQuery("http://jabber.org/protocol/si"); my $profile = $query->NewQuery("http://jabber.org/protocol/si/profile/tree-transfer"); my ($root) = ($args{directory} =~ /\/?([^\/]+)$/); my $rootDir = $profile->AddDirectory(name=>$root); my %tree; $tree{counter} = 0; $self->TreeTransferDescend($args{sidbase}, $args{directory}, $rootDir, \%tree ); $profile->SetTree(numfiles=>$tree{counter}, size=>$tree{size} ); $query->SetStream(id=>$args{sidbase}, profile=>"http://jabber.org/protocol/si/profile/tree-transfer" ); if ($#{$args{methods}} == -1) { print STDERR "You did not provide any valid methods for the tree transfer.\n"; return; } my $fneg = $self->FeatureNegQuery({'stream-method'=>$args{methods}}); $query->AddQuery($fneg); #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); $tree{id} = $id; return %tree; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); #-------------------------------------------------------------------------- # Check if there was an error. #-------------------------------------------------------------------------- return unless defined($iq); if ($iq->GetType() eq "error") { $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); return; } $query = $iq->GetQuery(); if (defined($query)) { my @fneg = $query->GetQuery("http://jabber.org/protocol/feature-neg"); my @xdata = $fneg[0]->GetX("jabber:x:data"); my @fields = $xdata[0]->GetFields(); return $fields[0]->GetValue(); # XXX need better error handling } else { return; } } ############################################################################### # # TreeTransferDescend - descend a directory structure and build the packet. # ############################################################################### sub TreeTransferDescend { my $self = shift; my $sidbase = shift; my $path = shift; my $parent = shift; my $tree = shift; $tree->{size} += (-s $path); opendir(DIR, $path); foreach my $file ( sort {$a cmp $b} readdir(DIR) ) { next if ($file =~ /^\.\.?$/); if (-d "$path/$file") { my $tempParent = $parent->AddDirectory(name=>$file); $self->TreeTransferDescend($sidbase, "$path/$file", $tempParent, $tree ); } else { $tree->{size} += (-s "$path/$file"); $tree->{tree}->{"$path/$file"}->{order} = $tree->{counter}; $tree->{tree}->{"$path/$file"}->{sid} = $sidbase."-".$tree->{counter}; $tree->{tree}->{"$path/$file"}->{name} = $file; $parent->AddFile(name=>$tree->{tree}->{"$path/$file"}->{name}, sid=>$tree->{tree}->{"$path/$file"}->{sid}); $tree->{counter}++; } } closedir(DIR); } ############################################################################### # # LastQuery - Sends an iq:last query to either the server or the specified # JID. # ############################################################################### sub LastQuery { my $self = shift; my %args; $args{mode} = "passthru"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $args{waitforid} = 0 unless exists($args{waitforid}); my $waitforid = delete($args{waitforid}); $args{mode} = "block" if $waitforid; my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); $iq->SetIQ(type=>'get'); my $last = $iq->NewQuery("jabber:iq:last"); if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); return unless defined($iq); $last = $iq->GetQuery(); return unless defined($last); return $last->GetLast(); } ############################################################################### # # LastSend - sends an iq:last packet to the specified user. # ############################################################################### sub LastSend { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $args{ignoreactivity} = 0 unless exists($args{ignoreactivity}); my $ignoreActivity = delete($args{ignoreactivity}); my $iq = $self->_iq(); $iq->SetIQ(to=>delete($args{to}), type=>'result'); my $last = $iq->NewQuery("jabber:iq:last"); $last->SetLast(%args); $self->Send($iq,$ignoreActivity); } ############################################################################### # # LastActivity - returns number of seconds since the last activity. # ############################################################################### sub LastActivity { my $self = shift; return (time - $self->{STREAM}->LastActivity($self->{SESSION}->{id})); } ############################################################################### # # RegisterSendData - This is a self contained function to send a register iq # tag with an id. It uses the jabber:x:data method to # return the data. # ############################################################################### sub RegisterSendData { my $self = shift; my $to = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } #-------------------------------------------------------------------------- # Create a Net::Jabber::IQ object to send to the server #-------------------------------------------------------------------------- my $iq = $self->_iq(); $iq->SetIQ(to=>$to) if (defined($to) && ($to ne "")); $iq->SetIQ(type=>"set"); my $iqRegister = $iq->NewQuery("jabber:iq:register"); my $xForm = $iqRegister->NewX("jabber:x:data"); foreach my $var (keys(%args)) { next if ($args{$var} eq ""); $xForm->AddField(var=>$var, value=>$args{$var} ); } #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- $iq = $self->SendAndReceiveWithID($iq); #-------------------------------------------------------------------------- # From the reply IQ determine if we were successful or not. If yes then # return "". If no then return error string from the reply. #-------------------------------------------------------------------------- return unless defined($iq); return ( $iq->GetErrorCode() , $iq->GetError() ) if ($iq->GetType() eq "error"); return ("ok",""); } ############################################################################### # # RPCSetCallBacks - place to register a callback for RPC calls. This is # used in conjunction with the default IQ callback. # ############################################################################### sub RPCSetCallBacks { my $self = shift; while($#_ >= 0) { my $func = pop(@_); my $method = pop(@_); $self->{DEBUG}->Log2("RPCSetCallBacks: method($method) func($func)"); if (defined($func)) { $self->{RPCCB}{$method} = $func; } else { delete($self->{RPCCB}{$method}); } } } ############################################################################### # # RPCCall - Make an RPC call to the specified JID. # ############################################################################### sub RPCCall { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(type=>"set", to=>delete($args{to})); $iq->AddQuery($self->RPCEncode(type=>"methodCall", %args)); if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); return unless defined($iq); return $self->RPCParse($iq); } ############################################################################### # # RPCResponse - Send back an RPC response, or fault, to the specified JID. # ############################################################################### sub RPCResponse { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $iq = $self->_iq(); $iq->SetIQ(type=>"result", to=>delete($args{to})); $iq->AddQuery($self->RPCEncode(type=>"methodResponse", %args)); $iq = $self->SendAndReceiveWithID($iq); return unless defined($iq); return $self->RPCParse($iq); } ############################################################################### # # RPCEncode - Returns a Net::Jabber::Query with the arguments encoded for the # RPC packet. # ############################################################################### sub RPCEncode { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $query = new Net::Jabber::Stanza("query"); $query->SetXMLNS("jabber:iq:rpc"); my $source; if ($args{type} eq "methodCall") { $source = $query->AddMethodCall(); $source->SetMethodName($args{methodname}); } if ($args{type} eq "methodResponse") { $source = $query->AddMethodResponse(); } if (exists($args{faultcode}) || exists($args{faultstring})) { my $struct = $source->AddFault()->AddValue()->AddStruct(); $struct->AddMember(name=>"faultCode")->AddValue(i4=>$args{faultcode}); $struct->AddMember(name=>"faultString")->AddValue(string=>$args{faultstring}); } elsif (exists($args{params})) { my $params = $source->AddParams(); foreach my $param (@{$args{params}}) { $self->RPCEncode_Value($params->AddParam(),$param); } } return $query; } ############################################################################### # # RPCEncode_Value - Run through the value, and encode it into XML. # ############################################################################### sub RPCEncode_Value { my $self = shift; my $obj = shift; my $value = shift; if (ref($value) eq "ARRAY") { my $array = $obj->AddValue()->AddArray(); foreach my $data (@{$value}) { $self->RPCEncode_Value($array->AddData(),$data); } } elsif (ref($value) eq "HASH") { my $struct = $obj->AddValue()->AddStruct(); foreach my $key (keys(%{$value})) { $self->RPCEncode_Value($struct->AddMember(name=>$key),$value->{$key}); } } else { if ($value =~ /^(int|i4|boolean|string|double|datetime|base64):/i) { my $type = $1; my($val) = ($value =~ /^$type:(.*)$/); $obj->AddValue($type=>$val); } elsif ($value =~ /^[+-]?\d+$/) { $obj->AddValue(i4=>$value); } elsif ($value =~ /^(-?(?:\d+(?:\.\d*)?|\.\d+)|([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?)$/) { $obj->AddValue(double=>$value); } else { $obj->AddValue(string=>$value); } } } ############################################################################### # # RPCParse - Returns an array of the params sent in the RPC packet. # ############################################################################### sub RPCParse { my $self = shift; my($iq) = @_; my $query = $iq->GetQuery(); my $source; $source = $query->GetMethodCall() if $query->DefinedMethodCall(); $source = $query->GetMethodResponse() if $query->DefinedMethodResponse(); if (defined($source)) { if (($source->GetTag() eq "methodResponse") && ($source->DefinedFault())) { my %response = $self->RPCParse_Struct($source->GetFault()->GetValue()->GetStruct()); return ("fault",\%response); } if ($source->DefinedParams()) { #------------------------------------------------------------------ # The <param/>s part #------------------------------------------------------------------ my @response; foreach my $param ($source->GetParams()->GetParams()) { push(@response,$self->RPCParse_Value($param->GetValue())); } return ("ok",\@response); } } else { print "AAAAHHHH!!!!\n"; } } ############################################################################### # # RPCParse_Value - Takes a <value/> and returns the data it represents # ############################################################################### sub RPCParse_Value { my $self = shift; my($value) = @_; if ($value->DefinedStruct()) { my %struct = $self->RPCParse_Struct($value->GetStruct()); return \%struct; } if ($value->DefinedArray()) { my @array = $self->RPCParse_Array($value->GetArray()); return \@array; } return $value->GetI4() if $value->DefinedI4(); return $value->GetInt() if $value->DefinedInt(); return $value->GetBoolean() if $value->DefinedBoolean(); return $value->GetString() if $value->DefinedString(); return $value->GetDouble() if $value->DefinedDouble(); return $value->GetDateTime() if $value->DefinedDateTime(); return $value->GetBase64() if $value->DefinedBase64(); return $value->GetValue(); } ############################################################################### # # RPCParse_Struct - Takes a <struct/> and returns the hash of values. # ############################################################################### sub RPCParse_Struct { my $self = shift; my($struct) = @_; my %struct; foreach my $member ($struct->GetMembers()) { $struct{$member->GetName()} = $self->RPCParse_Value($member->GetValue()); } return %struct; } ############################################################################### # # RPCParse_Array - Takes a <array/> and returns the hash of values. # ############################################################################### sub RPCParse_Array { my $self = shift; my($array) = @_; my @array; foreach my $data ($array->GetDatas()) { push(@array,$self->RPCParse_Value($data->GetValue())); } return @array; } ############################################################################### # # SearchRequest - This is a self contained function to send an iq tag # an id that requests the target address to send back # the required fields. It waits for a reply what the # same id to come back and tell the caller what the # fields are. # ############################################################################### sub SearchRequest { my $self = shift; my %args; $args{mode} = "block"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; #-------------------------------------------------------------------------- # Create a Net::Jabber::IQ object to send to the server #-------------------------------------------------------------------------- my $iq = $self->_iq(); $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); $iq->SetIQ(type=>"get"); my $query = $iq->NewQuery("jabber:iq:search"); $self->{DEBUG}->Log1("SearchRequest: sent(",$iq->GetXML(),")"); #-------------------------------------------------------------------------- # Send the IQ with the next available ID and wait for a reply with that # id to be received. Then grab the IQ reply. #-------------------------------------------------------------------------- if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); $self->{DEBUG}->Log1("SearchRequest: received(",$iq->GetXML(),")") if defined($iq); #-------------------------------------------------------------------------- # Check if there was an error. #-------------------------------------------------------------------------- return unless defined($iq); if ($iq->GetType() eq "error") { $self->SetErrorCode($iq->GetErrorCode().": ".$iq->GetError()); $self->{DEBUG}->Log1("SearchRequest: error(",$self->GetErrorCode(),")"); return; } my %search; #-------------------------------------------------------------------------- # From the reply IQ determine what fields are required and send a hash # back with the fields and any values that are already defined (like key) #-------------------------------------------------------------------------- $query = $iq->GetQuery(); $search{fields} = { $query->GetSearch() }; #-------------------------------------------------------------------------- # Get any forms so that we have the option of showing a nive dynamic form # to the user and not just a bunch of fields. #-------------------------------------------------------------------------- &ExtractForms(\%search,$query->GetX("jabber:x:data")); #-------------------------------------------------------------------------- # Get any oobs so that we have the option of sending the user to the http # form and not a dynamic one. #-------------------------------------------------------------------------- &ExtractOobs(\%search,$query->GetX("jabber:x:oob")); return %search; } ############################################################################### # # SearchSend - This is a self contained function to send a search # iq tag with an id. Then wait for a reply what the same # id to come back and tell the caller what the result was. # ############################################################################### sub SearchSend { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } #-------------------------------------------------------------------------- # Create a Net::Jabber::IQ object to send to the server #-------------------------------------------------------------------------- my $iq = $self->_iq(); $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); $iq->SetIQ(type=>"set"); my $iqSearch = $iq->NewQuery("jabber:iq:search"); $iqSearch->SetSearch(%args); #-------------------------------------------------------------------------- # Send the IQ. #-------------------------------------------------------------------------- $self->Send($iq); } ############################################################################### # # SearchSendData - This is a self contained function to send a search iq tag # with an id. It uses the jabber:x:data method to return the # data. # ############################################################################### sub SearchSendData { my $self = shift; my $to = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } #-------------------------------------------------------------------------- # Create a Net::Jabber::IQ object to send to the server #-------------------------------------------------------------------------- my $iq = $self->_iq(); $iq->SetIQ(to=>$to) if (defined($to) && ($to ne "")); $iq->SetIQ(type=>"set"); my $iqSearch = $iq->NewQuery("jabber:iq:search"); my $xForm = $iqSearch->NewX("jabber:x:data"); foreach my $var (keys(%args)) { next if ($args{$var} eq ""); $xForm->AddField(var=>$var, value=>$args{$var} ); } #-------------------------------------------------------------------------- # Send the IQ. #-------------------------------------------------------------------------- $self->Send($iq); } ############################################################################### # # TimeQuery - Sends an iq:time query to either the server or the specified # JID. # ############################################################################### sub TimeQuery { my $self = shift; my %args; $args{mode} = "passthru"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $args{waitforid} = 0 unless exists($args{waitforid}); my $waitforid = delete($args{waitforid}); $args{mode} = "block" if $waitforid; my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); $iq->SetIQ(type=>'get',%args); my $time = $iq->NewQuery("jabber:iq:time"); if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); return unless defined($iq); my $query = $iq->GetQuery(); return unless defined($query); my %result; $result{utc} = $query->GetUTC(); $result{display} = $query->GetDisplay(); $result{tz} = $query->GetTZ(); return %result; } ############################################################################### # # TimeSend - sends an iq:time packet to the specified user. # ############################################################################### sub TimeSend { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $iq = $self->_iq(); $iq->SetIQ(to=>delete($args{to}), type=>'result'); my $time = $iq->NewQuery("jabber:iq:time"); $time->SetTime(%args); $self->Send($iq); } ############################################################################### # # VersionQuery - Sends an iq:version query to either the server or the # specified JID. # ############################################################################### sub VersionQuery { my $self = shift; my %args; $args{mode} = "passthru"; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } $args{waitforid} = 0 unless exists($args{waitforid}); my $waitforid = delete($args{waitforid}); $args{mode} = "block" if $waitforid; my $timeout = exists($args{timeout}) ? delete($args{timeout}) : undef; my $iq = $self->_iq(); $iq->SetIQ(to=>delete($args{to})) if exists($args{to}); $iq->SetIQ(type=>'get',%args); my $version = $iq->NewQuery("jabber:iq:version"); if ($args{mode} eq "passthru") { my $id = $self->UniqueID(); $iq->SetIQ(id=>$id); $self->Send($iq); return $id; } return $self->SendWithID($iq) if ($args{mode} eq "nonblock"); $iq = $self->SendAndReceiveWithID($iq,$timeout); return unless defined($iq); my $query = $iq->GetQuery(); return unless defined($query); my %result; $result{name} = $query->GetName(); $result{ver} = $query->GetVer(); $result{os} = $query->GetOS(); return %result; } ############################################################################### # # VersionSend - sends an iq:version packet to the specified user. # ############################################################################### sub VersionSend { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $iq = $self->_iq(); $iq->SetIQ(to=>delete($args{to}), type=>'result'); my $version = $iq->NewQuery("jabber:iq:version"); $version->SetVersion(%args); $self->Send($iq); } ############################################################################### # # MUCJoin - join a MUC room # ############################################################################### sub MUCJoin { my $self = shift; my %args; while($#_ >= 0) { $args{ lc pop(@_) } = pop(@_); } my $presence = $self->_presence(); $presence->SetTo($args{room}.'@'.$args{server}.'/'.$args{nick}); my $x = $presence->NewChild("http://jabber.org/protocol/muc"); if (exists($args{password}) && ($args{password} ne "")) { $x->SetMUC(password=>$args{password}); } return $presence->GetXML() if exists($args{'__netjabber__:test'}); $self->Send($presence); } ############################################################################### #+----------------------------------------------------------------------------- #| #| Helper Functions #| #+----------------------------------------------------------------------------- ############################################################################### ############################################################################### # # ExtractForms - Helper function to make extracting jabber:x:data for forms # more centrally definable. # ############################################################################### sub ExtractForms { my ($target,@xForms) = @_; my $tempVar = "1"; foreach my $xForm (@xForms) { $target->{instructions} = $xForm->GetInstructions(); my $order = 0; foreach my $field ($xForm->GetFields()) { $target->{form}->[$order]->{type} = $field->GetType() if $field->DefinedType(); $target->{form}->[$order]->{label} = $field->GetLabel() if $field->DefinedLabel(); $target->{form}->[$order]->{desc} = $field->GetDesc() if $field->DefinedDesc(); $target->{form}->[$order]->{var} = $field->GetVar() if $field->DefinedVar(); $target->{form}->[$order]->{var} = "__netjabber__:tempvar:".$tempVar++ if !$field->DefinedVar(); if ($field->DefinedValue()) { if ($field->GetType() eq "list-multi") { $target->{form}->[$order]->{value} = [ $field->GetValue() ]; } else { $target->{form}->[$order]->{value} = ($field->GetValue())[0]; } } my $count = 0; foreach my $option ($field->GetOptions()) { $target->{form}->[$order]->{options}->[$count]->{value} = $option->GetValue(); $target->{form}->[$order]->{options}->[$count]->{label} = $option->GetLabel(); $count++; } $order++; } foreach my $reported ($xForm->GetReported()) { my $order = 0; foreach my $field ($reported->GetFields()) { $target->{reported}->[$order]->{label} = $field->GetLabel(); $target->{reported}->[$order]->{var} = $field->GetVar(); $order++; } } } } ############################################################################### # # ExtractOobs - Helper function to make extracting jabber:x:oob for forms # more centrally definable. # ############################################################################### sub ExtractOobs { my ($target,@xOobs) = @_; foreach my $xOob (@xOobs) { $target->{oob}->{url} = $xOob->GetURL(); $target->{oob}->{desc} = $xOob->GetDesc(); } } ############################################################################### #+----------------------------------------------------------------------------- #| #| Default CallBacks #| #+----------------------------------------------------------------------------- ############################################################################### ############################################################################### # # callbackInit - initialize the default callbacks # ############################################################################### sub callbackInit { my $self = shift; $self->SUPER::callbackInit(); $self->SetIQCallBacks("jabber:iq:last"=> { get=>sub{ $self->callbackGetIQLast(@_) }, result=>sub{ $self->callbackResultIQLast(@_) } }, "jabber:iq:rpc"=> { set=>sub{ $self->callbackSetIQRPC(@_) }, }, "jabber:iq:time"=> { get=>sub{ $self->callbackGetIQTime(@_) }, result=>sub{ $self->callbackResultIQTime(@_) } }, "jabber:iq:version"=> { get=>sub{ $self->callbackGetIQVersion(@_) }, result=>sub{ $self->callbackResultIQVersion(@_) } }, ); } ############################################################################### # # callbackSetIQRPC - callback to handle auto-replying to an iq:rpc by calling # the user registered functions. # ############################################################################### sub callbackSetIQRPC { my $self = shift; my $sid = shift; my $iq = shift; my $query = $iq->GetQuery(); my $reply = $iq->Reply(type=>"result"); my $replyQuery = $reply->GetQuery(); if (!$query->DefinedMethodCall()) { my $methodResponse = $replyQuery->AddMethodResponse(); my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); $struct->AddMember(name=>"faultCode")->AddValue(int=>400); $struct->AddMember(name=>"faultString")->AddValue(string=>"Missing methodCall."); $self->Send($reply,1); return; } if (!$query->GetMethodCall()->DefinedMethodName()) { my $methodResponse = $replyQuery->AddMethodResponse(); my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); $struct->AddMember(name=>"faultCode")->AddValue(int=>400); $struct->AddMember(name=>"faultString")->AddValue(string=>"Missing methodName."); $self->Send($reply,1); return; } my $methodName = $query->GetMethodCall()->GetMethodName(); if (!exists($self->{RPCCB}->{$methodName})) { my $methodResponse = $replyQuery->AddMethodResponse(); my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); $struct->AddMember(name=>"faultCode")->AddValue(int=>404); $struct->AddMember(name=>"faultString")->AddValue(string=>"methodName $methodName not defined."); $self->Send($reply,1); return; } my @params = $self->RPCParse($iq); my @return = &{$self->{RPCCB}->{$methodName}}($iq,$params[1]); if ($return[0] ne "ok") { my $methodResponse = $replyQuery->AddMethodResponse(); my $struct = $methodResponse->AddFault()->AddValue()->AddStruct(); $struct->AddMember(name=>"faultCode")->AddValue(int=>$return[1]->{faultCode}); $struct->AddMember(name=>"faultString")->AddValue(string=>$return[1]->{faultString}); $self->Send($reply,1); return; } $reply->RemoveQuery(); $reply->AddQuery($self->RPCEncode(type=>"methodResponse", params=>$return[1])); $self->Send($reply,1); } ############################################################################### # # callbackGetIQTime - callback to handle auto-replying to an iq:time get. # ############################################################################### sub callbackGetIQTime { my $self = shift; my $sid = shift; my $iq = shift; my $query = $iq->GetQuery(); my $reply = $iq->Reply(type=>"result"); my $replyQuery = $reply->GetQuery(); $replyQuery->SetTime(); $self->Send($reply,1); } ############################################################################### # # callbackResultIQTime - callback to handle formatting iq:time result into # a message. # ############################################################################### sub callbackResultIQTime { my $self = shift; my $sid = shift; my $iq = shift; my $fromJID = $iq->GetFrom("jid"); my $query = $iq->GetQuery(); my $body = "UTC: ".$query->GetUTC()."\n"; $body .= "Time: ".$query->GetDisplay()."\n"; $body .= "Timezone: ".$query->GetTZ()."\n"; my $message = $self->_message(); $message->SetMessage(to=>$iq->GetTo(), from=>$iq->GetFrom(), subject=>"CTCP: Time", body=>$body); $self->CallBack($sid,$message); } ############################################################################### # # callbackGetIQVersion - callback to handle auto-replying to an iq:time # get. # ############################################################################### sub callbackGetIQVersion { my $self = shift; my $sid = shift; my $iq = shift; my $query = $iq->GetQuery(); my $reply = $iq->Reply(type=>"result"); my $replyQuery = $reply->GetQuery(); $replyQuery->SetVersion(name=>$self->{INFO}->{name}, ver=>$self->{INFO}->{version}, os=>""); $self->Send($reply,1); } ############################################################################### # # callbackResultIQVersion - callback to handle formatting iq:time result # into a message. # ############################################################################### sub callbackResultIQVersion { my $self = shift; my $sid = shift; my $iq = shift; my $query = $iq->GetQuery(); my $body = "Program: ".$query->GetName()."\n"; $body .= "Version: ".$query->GetVer()."\n"; $body .= "OS: ".$query->GetOS()."\n"; my $message = $self->_message(); $message->SetMessage(to=>$iq->GetTo(), from=>$iq->GetFrom(), subject=>"CTCP: Version", body=>$body); $self->CallBack($sid,$message); } ############################################################################### # # callbackGetIQLast - callback to handle auto-replying to an iq:last get. # ############################################################################### sub callbackGetIQLast { my $self = shift; my $sid = shift; my $iq = shift; my $query = $iq->GetQuery(); my $reply = $iq->Reply(type=>"result"); my $replyQuery = $reply->GetQuery(); $replyQuery->SetLast(seconds=>$self->LastActivity()); $self->Send($reply,1); } ############################################################################### # # callbackResultIQLast - callback to handle formatting iq:last result into # a message. # ############################################################################### sub callbackResultIQLast { my $self = shift; my $sid = shift; my $iq = shift; my $fromJID = $iq->GetFrom("jid"); my $query = $iq->GetQuery(); my $seconds = $query->GetSeconds(); my $lastTime = &Net::Jabber::GetTimeStamp("local",(time - $seconds),"long"); my $elapsedTime = &Net::Jabber::GetHumanTime($seconds); my $body; if ($fromJID->GetUserID() eq "") { $body = "Start Time: $lastTime\n"; $body .= "Up time: $elapsedTime\n"; $body .= "Message: ".$query->GetMessage()."\n" if ($query->DefinedMessage()); } elsif ($fromJID->GetResource() eq "") { $body = "Logout Time: $lastTime\n"; $body .= "Elapsed time: $elapsedTime\n"; $body .= "Message: ".$query->GetMessage()."\n" if ($query->DefinedMessage()); } else { $body = "Last activity: $lastTime\n"; $body .= "Elapsed time: $elapsedTime\n"; $body .= "Message: ".$query->GetMessage()."\n" if ($query->DefinedMessage()); } my $message = $self->_message(); $message->SetMessage(from=>$iq->GetFrom(), subject=>"Last Activity", body=>$body); $self->CallBack($sid,$message); } 1;