Volity::Jabber - a base class for Jabber-speaking Volity objects

 package My::Volity::Object;
 use base qw(Volity::Jabber);
 use fields qw(wubba_wubba);

 # Override the parent's initialize method to set values on construction.
 sub initialize {
   my $self = shift;
   $self->SUPER::initialize(@_);   # Don't forget to call the parent's init!
   # Initialization goes here
   $self->wubba_wubba('grink gronk');
 }

 # An example chat handler, defined by the base class
 sub handle_groupchat_message {
   my $self = shift;
   my ($message) = @_;  # A hashref with info about the incoming message.
   # Send a debug message.
   $self->logger->debug(sprintf("%s says, '%s'\n", $$message{from}, $$message{body}));
   # More use message-handling code goes here.
 }

 { 
   'en' => "This is some localized text.",
   'es' => "Éste es un poco de texto localizado.",
   'fr' => "C'est un certain texte localisé.",
   'ru' => "Это будет некоторый локализованный текст.",
 }

 "This string is available in English only. C'est la vie."

package Volity::Jabber;
use Carp;

use Data::Dumper;

############################################################################
# LICENSE INFORMATION - PLEASE READ
############################################################################
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 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
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser 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
############################################################################

# This is a superclass for Volity objects, giving them super-duper Jabber
# powers. Poe::Component::Jabber powers, actually.

# Annoyingly "perldoc" doesn't support =encoding even though it's documented
# in perlpod.  It does make you wonder _who_ supports it of perldoc
# doesn't...

use base qw(Volity);

use warnings; no warnings qw(deprecated);
use strict;

use POE qw(
	   Wheel::SocketFactory
	   Wheel::ReadWrite
	   Filter::Line
	   Driver::SysRW
           Component::Jabber::Error
           Component::Jabber::ProtocolFactory
           Component::Jabber::Status
	  );
use POE::Filter::XML::Node;

use PXR::NS qw(:JABBER :IQ);
use Scalar::Util qw(weaken);
use Carp qw(croak);
use RPC::XML::Parser;

use fields qw(kernel main_session_id alias host jid_host port user resource password jid rpc_parser default_language query_handlers roster iq_notification last_id response_handler error_notification last_node);

sub initialize {
    my $self = shift;
    $self->{kernel} = $poe_kernel;
    $self->{port} ||= 5222;
    $self->logger->debug("STARTING init. Password is " . $self->password);
    POE::Session->create(
			 object_states=>
			 [$self=>
			  [qw(jabber_iq jabber_presence _start jabber_message input_event status_event error_event)],
			  ],
			 );

    # Weaken some variables to prevent circularities & such.
    foreach (qw(kernel)) {
	weaken($self->{$_});
    }

    foreach (qw(user host resource)) {
	unless ($self->$_) {
	    die "Failed to make a Jabber connection with $self, because the $_ field is empty.";
	}
    }
    
    $self->jid(sprintf("%s@%s/%s", $self->user, $self->jid_host || $self->host, $self->resource));
    $self->rpc_parser(RPC::XML::Parser->new);
    $self->default_language('en') unless defined($self->default_language);
    
    # Give initial values to instance variables what needs 'em.
    $self->{query_handlers} = {
	'jabber:iq:roster'=>{
	    result => 'receive_roster',
	    set => 'update_roster',
	},
	'http://jabber.org/protocol/disco#items'=>{
	    get    => 'handle_disco_items_request',
	    result => 'receive_disco_items',
	},
	'http://jabber.org/protocol/disco#info'=>{
	    get    => 'handle_disco_info_request',
	    result => 'receive_disco_info',
	},
	'jabber:iq:register'=>{
	    error  => 'receive_registration_error'
	    },
	    };
    
    $self->{iq_notification} = {};
    $self->{last_id} = 0;
    
    return $self;
}

sub set_iq_notification {
  my $self = shift;
  my ($id, $methods) = @_;
  unless (ref($methods) eq 'HASH') {
    croak("The second arg to set_iq_notification must be a hashref.");
  }
  $self->{iq_notification}->{$id} = $methods;
}

sub next_id {
  my $self = shift;
  return ++$self->{last_id};
}

# post_node: send a given XML node object to the server.
# Rewrite this sub if our core Jabber/POE thing changes.
sub post_node {
  my $self = shift;
  my ($node) = @_;
  # I always set the stanza-level xml:lang attribute here.
  # Is it a bit much? Not sure. It's easy, anyway, and I figure it can't hurt.
  $node->attr('xml:lang'=>$self->default_language);
  $self->last_node($node);
  $self->kernel->post($self->alias, 'output_handler', $node);
}

################################
# POE States (core)
################################

sub _start {
    my $self = $_[OBJECT];
    my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
    $self->main_session_id($session->ID);
    $self->start_jabber_client;
}

sub start_jabber_client {
    my $self = shift;
    my $alias = $self->alias;
    unless (defined($self->alias)) {
	die "You haven't set an alias on $self! Please do that when constucting the object.";
    }

    foreach (qw(host jid_host port user password resource)) {
	unless (defined($self->$_)) {
	    $self->expire("I can't start the Jabber connection without my '$_' field defined. Please define it and try again.");
	}
    }

    my %config = (
		  Alias=>$alias,
#		  STATE_PARENT=>$self->main_session_id,
		  States=>{
                           StatusEvent=>'status_event',
                           InputEvent=>'input_event',
                           ErrorEvent=>'error_event',
                       },
#		  XMLNS => +NS_JABBER_CLIENT,
#		  STREAM => +XMLNS_STREAM,
		  IP=>$self->host,
		  Hostname=>$self->jid_host,
		  Port=>$self->port,
                  ConnectionType => +LEGACY,
		  Username=>$self->user,
		  Password=>$self->password,
		  Resource=>$self->resource,
		  );


    POE::Component::Jabber->new(%config);

    $poe_kernel->post($alias, 'connect');


}

################################
# POE States (Jabber)
################################

sub status_event {
  my $self = $_[OBJECT];
  my $event = $_[ARG0];
  if ($event == +PCJ_INIT_FINISHED) {
      $self->logger->debug("I got an init finished event!");
      $self->init_finish;
  }
  else {
#      $self->logger->debug("I got some other kind of status update event!");
  }
}

sub init_finish {
    my $self = shift;
    $self->kernel->post($self->alias, 'set_auth', 'jabber_authed', $self->user, $self->password, $self->resource);

    # Always request roster. The roster's receipt will trigger an 'available'
    # presence packet (see 'receive_roster').
    $self->request_roster;
}

sub input_event {
  my $self = $_[OBJECT];
  my $node = $_[ARG0];
  my $element_type = $node->name;
  my $method = "jabber_$element_type";
  $method =~ s/\W/_/g;
  if ($self->can($method)) {
      $self->$method($node);
  }
  elsif ($node->to_str eq "</stream:stream>") {
      $self->logger->warn("The Jabber stream shut down!");
  } else {
      $self->logger->error("Got an input event that I have no idea how to handle, so I'll ignore it and chug merrily along. Who knows what will happen next?\nThis was the XML:\n" . $node->to_str);
  }
}

sub error_event {
  my $self = $_[OBJECT];
  my $error = $_[ARG0];
  
  my $error_message;
  if($error == +PCJ_SOCKETFAIL)  {
      my ($call, $code, $err) = @_[ARG1..ARG3];
      $error_message = "Socket error: $call, $code, $err\n";
  } elsif ($error == +PCJ_SOCKETDISCONNECT) {
      $error_message = "We got disconnected.\n";
      $self->react_to_disconnection_error;
  } elsif ($error == +PCJ_AUTHFAIL) {
      $error_message = "Failed to authenticate\n";
  } elsif ($error == +PCJ_BINDFAIL) {
      $error_message = "Failed to bind a resource\n"; # XMPP/J2 Only
  } elsif ($error == +PCJ_SESSIONFAIL) {
      $error_message = "Failed to establish a session\n"; # XMPP Only
  } else {
      $error_message = "Unknown PCJ Error: $error";
  }

  $self->logger->warn($error_message);
}

# react_to_disconnection_error: Called as a result of the error_event method
# getting notifcation that the Jabber stream has closed.
# By default, it does nothing at all, and the object quietly accepts its fate.
# Subclasses can ovveride this in order to do other things, such as attempt to
# reconnect to the server
sub react_to_disconnection_error { }

# Actually, these are all just stubs. It's up to subclasses for making
# these do real stuff.

sub jabber_presence { }

sub jabber_authed { }

# The IQ-handler checks for a bunch of special query types, like RPC calls.
# These then get delegated to other methods.
# Subclasses that ovveride this method should take care to call
# SUPER::jabber_iq in their own version of the method.

# This is a little sloppy, with namespace-handling. Er, sloppy? I meant to 
# say, "transitional".
sub jabber_iq {
  my $self = shift;
  $self->logger->debug("I ($self) got an IQ object.\n");
  my ($node) = @_;
#  warn $node->to_str;
  my $id = $node->attr('id'); my $from_jid = $node->attr('from');
  $id ||= $self->next_id;
  my $query;
  # Check to see if we should dispatch this to a predefined NS handler
  # method.
  return if $self->handle_query_element_ns($node);
  if ($node->attr('type') eq 'result') {
    if ($query = $node->get_tag('query') and $query->attr('xmlns') eq 'jabber:iq:rpc') {
      # Yep, that's an RPC response.
      my $raw_xml = join("\n", map($_->to_str, @{$query->get_children}));

      massage_rpc_numbers(\$raw_xml);

      # We should be getting only RPC responses, not requests.
      my $response_obj = $self->rpc_parser->parse($raw_xml);
      unless (ref($response_obj)) {
	  $self->logger->warn("Failed to parse this response: $raw_xml");
	  return;
      }
      $self->logger->debug("The response is: " . Dumper($response_obj->value->value) . "\n");
      if ($response_obj->value->is_fault) {
	$self->handle_rpc_fault({
				 id=>$id,
				 fault_code=>$response_obj->value->code,
				 fault_string=>$response_obj->value->string,
				 rpc_object=>$response_obj,
				 from=>$from_jid,
				});
      } else {
	$self->handle_rpc_response({id=>$id,
				    response=>$response_obj->value->value,
				    rpc_object=>$response_obj,
				    from=>$from_jid,
				   });
      }
    }
  } elsif ($node->attr('type') eq 'set') {
    if ($query = $node->get_tag('query') and $query->attr('xmlns') eq 'jabber:iq:rpc') {
      my $raw_xml = join("\n", map($_->to_str, @{$query->get_children}));

      # Hack, to deal with apparent RPC::XML bug?
      $raw_xml =~ s/<int\/>/<int>0<\/int>/g;

      massage_rpc_numbers(\$raw_xml);

      $self->logger->debug("$self got Apparent RPC XML from $from_jid: $raw_xml\n");
      my @kids = @{$query->get_children};
      my $rpc_obj = $self->rpc_parser->parse($raw_xml);
      unless (ref($rpc_obj)) {
	  die "Got bad rpc.\n$raw_xml";
      }
#      $self->logger->debug( "Finally, got $rpc_obj.\n");
      my $method = $rpc_obj->name;
      $self->handle_rpc_request({
				 rpc_object=>$rpc_obj,
				 from=>$from_jid,
				 id=>$id,
				 method=>$method,
				 args=>[map($_->value, @{$rpc_obj->args})],
			       });
    }
  } elsif ($node->attr('type') eq 'error') {
    if ($query = $node->get_tag('query') and $query->attr('xmlns') eq 'jabber:iq:rpc') {
      # This isn't an RPC fault, but an apparent error in trying to send the
      # RPC message at all.
      my $error_message = $node->get_tag('error')->data;
      my $code = $node->get_tag('error')->attr('code');
      $self->handle_rpc_transmission_error($node, $code, $error_message);
    } else {
      if (my $method = delete($self->{error_notification}->{$id})) {
	delete($self->{result_notification}->{$id});
	$self->$method($node);
      }
    }
  }
  if (my $methods = delete($self->{iq_notification}->{$id})) {
    if (my $method = $$methods{$node->attr('type')}) {
      $self->$method($node);
    }
  }
}

# error_with_node: convenience method that, given an XML node object and
# a string, sticks an error in the logger and also dumps the node as a
# string into it.
sub error_with_node {
    my $self = shift;
    my ($node, $error_message) = @_;
    $self->logger->error($error_message . "\nThe XML node in question was:\n" . $node->to_str);
}

# massage_rpc_numbers: Fixes Bug #1372065.
# Basically, if a <double> looks, walks and talks like an <int>, then
# an <int> it shall become.
sub massage_rpc_numbers {
    my ($raw_xml_ref) = @_;
    $$raw_xml_ref =~ s|<\s*double\s*>\s*(-?)(\d*?)\.0*\s*<\s*/\s*double\s*>|$2 ne '' ? "<int>$1$2</int>" : "<int>0<int>"|ge;
}

# Message handler! Figures out the message type, and calls a deleagating
# method.

sub jabber_message {
  my $self = shift;
  my ($node) = @_;
  my $info_hash;		# Will be the argument to the delegate method.
  my $type;			# What type of chat is this?
  $self->logger->debug( "I ($self) received a message...\n");

  foreach (qw(to from)) {
    $$info_hash{$_} = $node->attr($_);
  }
  foreach (qw(subject body thread)) {
    my $data;
    if (my $element = $node->get_tag($_)) {
      $data = $element->data;
    }
    $$info_hash{$_} = $data;
  }
  $type = $node->attr('type') || 'normal';
  my $method = "handle_${type}_message";
  $self->logger->debug( "Delegating it to the $method method.");
  $self->$method($info_hash);
  $self->logger->debug( "Done delegating to $method." );
}

# We could use some more useful stream-error handling...
sub jabber_stream_error { 
  my $self = shift;
  my ($node) = @_;
  $self->logger->debug("Got a jabber stream error. " . $node->to_str);
}
  

################################
# Jabber event delegate methods
################################

sub add_response_handler {
  my $self = shift;
  my ( $id, $sub ) = @_;
  my $response_handler = $self->{'response_handler'} ||= {};
  # If it's a code ref then store as is...
  if (ref $sub eq 'CODE') {
    $$response_handler{ $id } = $sub;
  } else { # else we assume it's a method name
    my $method = "rpc_response_$sub";
    if ( $self->can( $method ) ) {
      $$response_handler{ $id } = sub { $self->$method( @_ ) };
    } else {
      croak "Can't add response handler, unknown method $method.\n";
    }
  }
}

sub have_response_handler {
  my $self = shift;
  my ( $id ) = @_;
  return exists( $self->{'response_handler'}{ $id } ) ? 1 : 0;
}

sub call_response_handler {
  my $self = shift;
  my ( $id, $response ) = @_;
  return &{ $self->{'response_handler'}{ $id } }( $response );
}

sub delete_response_handler {
  my $self = shift;
  my ( $id ) = @_;
  delete( $self->{'response_handler'}{ $id } );
}

sub handle_rpc_response {
  my $self = shift;
  my ($message) = @_;
  if ($self->have_response_handler( $$message{'id'} )) {
    $self->call_response_handler( $$message{'id'}, $message );
    $self->delete_response_handler( $$message{'id'} );
  } else {
    $self->rpc_response_default( $message );
  }
}
# No default behavior for RPC stuff.
sub rpc_response_default { }
sub handle_rpc_request { }
sub handle_rpc_transmission_error { }
sub handle_rpc_fault { }

sub handle_normal_message { }
sub handle_groupchat_message { }
sub handle_chat_message { }
sub handle_headline_message { }
sub handle_error_message { }

# handle_query_element_ns:
# Returns truth if it performed a dispatch, falsehood otherwise.
sub handle_query_element_ns {
  my $self = shift;
  my ($node) = @_;
  my $element_type = $node->name;
  my $query_ns;
  if (my $query = $node->get_tag('query')) {
    $query_ns = $query->attr('xmlns');
  }  
  return unless defined($query_ns);

  $self->logger->debug("I am $self in handle_query_element_ns, for $query_ns...");
  return unless defined($query_ns);
  return unless defined($self->query_handlers);
  return unless defined($self->query_handlers->{$query_ns});

  $self->logger->debug("I'm handling a query of the $query_ns namespace.");

  if ($element_type eq 'iq') {
    # Locate a dispatch method, depending upon the type of the iq.
    my $method;
    my $type = $node->attr('type');
    unless (defined($type)) {
      $self->error_with_node($node, "No type attribute defined in query's parent node! Gak!");
      return;
    }
    $method = $self->query_handlers->{$query_ns}->{$type};
    if (defined($method)) {
      $self->logger->debug("Trying to call the $method method.");
      if ($self->can($method)) {
	$self->$method($node);
	return 1;
      } else {
	croak("I wanted to dispatch to the $method method, but I have no such method defined!");
      }
    } else {
      # No method for this situation is set; we'll return undef.
      # This probably will return control to the jabber_iq method.
      return;
    }
  } else {
    $self->error_with_node($node, "handle_query_element_ns called with a non-iq element. It was a $element_type.");
  }
}
    
################################
# Jabber element-sending methods
################################

*make_rpc_request = \&send_rpc_request;

sub send_rpc_request {
  my $self = shift;
  $self->logger->debug("in make_rpc_request\n");
  my ($args) = @_;
  my $iq = POE::Filter::XML::Node->new('iq');  
  foreach (qw(to id)) {
      unless (defined($$args{$_})) {
	  $self->expire("send_rpc_request called without an $_ argument.");
      }
      $iq->attr($_, $$args{$_});
  }
  $iq->attr(type=>'set');
  my @args;
  if (defined($$args{args})) {
    if (ref($$args{args}) and ref($$args{args}) eq 'ARRAY') {
      @args = @{$$args{args}};
    } else {
      @args = ($$args{args});
    }
  } else {
    @args = ();
  }

  if ( exists $$args{'handler'} ) {
      $self->add_response_handler( $$args{'id'}, $$args{'handler'} );
  }

  my $request = RPC::XML::request->new($$args{methodname}, @args);
  $self->logger->debug("The request is $$args{methodname}, and the args: @args");
  $self->logger->debug("It's going out to $$args{to}.");

  # I don't like this so much, sliding in the request as raw data.
  # But then, I can't see why it would break.
  my $request_xml = $request->as_string;
  $request_xml =~ s/^<\?\s*xml\s.*?\?>//;
  $iq->insert_tag('query', [xmlns=>'jabber:iq:rpc'])->
    rawdata($request_xml);
  $self->logger->debug("Full, outgoing RPC request:\n" . $iq->to_str);
  $self->post_node($iq);
}

sub send_rpc_response {
  my $self = shift;
  my ($receiver_jid, $id_attr, $value) = @_;
  my $response = RPC::XML::response->new($value);
  my $rpc_iq = POE::Filter::XML::Node->new('iq');
  $rpc_iq->attr(type=>'result');
  $rpc_iq->attr(from=>$self->jid);
  $rpc_iq->attr(to=>$receiver_jid);
  $rpc_iq->attr(id=>$id_attr);
  # I don't like this so much, sliding in the response as raw data.
  # But then, I can't see why it would break.
  my $response_xml = $response->as_string;
  # This s/// chops off the XML prolog.
  # (Ugly, yes. Suggestions welcome.)
  $response_xml =~ s/^<\s*\?\s*xml\s.*?\?\s*>//;
  $rpc_iq->insert_tag(query=>[xmlns=>'jabber:iq:rpc'])
    ->rawdata($response_xml);
  $self->logger->debug("Sending response: " . $rpc_iq->to_str);
  $self->post_node($rpc_iq);
  return 1;
}

sub send_rpc_fault {
  my $self = shift;
  my ($receiver_jid, $response_id, $fault_code, $fault_string) = @_;
  my $fault = RPC::XML::fault->new($fault_code, $fault_string);
  $self->send_rpc_response($receiver_jid, $response_id, $fault);
}

sub send_message {
  my $self = shift;
  my ($config) = @_;
  my $message = POE::Filter::XML::Node->new('message');
  foreach (qw(to type from)) {
    $message->attr($_=>$$config{$_}) if defined($$config{$_});
  }
  foreach (qw(thread)) {
    $message->insert_tag($_)->data($$config{$_}) if defined($$config{$_});
  }
  # Handle possibly multiple subject and body elements, if the sender
  # uses localization.
  foreach (qw(subject body)) {
    if (defined($$config{$_})) {
      if (ref($$config{$_}) and ref($$config{$_}) eq 'HASH') {
	while (my($language, $text) = each(%{$$config{$_}})) {
	  unless ($language =~ /^\w\w$|^\w\w-\w\w$/) {
	    croak("Language must be of the form 'xx' or 'xx-xx', but you sent '$language'.");
	  }
	  my $tag = $message->insert_tag($_);
	  $tag->attr("xml:lang"=>$language);
	  $tag->data($text);
	}
      } elsif (not(ref($$config{$_}))) {
	$message->insert_tag($_)->data($$config{$_});
      } else {
	croak("$_ must be either a hashref (for localization) or a string (for default langauge)");
      }
    }
  }

  if ($$config{invitation}) {
      unless (ref($$config{invitation}) eq 'HASH') {
	  $self->expire("The 'invitation' key to the 'send_message' method has to contain a hash reference.");
      }
      my $form = Volity::Jabber::Form->new({type=>'result'});
      my @fields;
      my $type_field = Volity::Jabber::Form::Field->new({var=>"FORM_TYPE",
							 type=>"hidden",
						     });
      $type_field->values("http://volity.org/protocol/form/invite");
      push (@fields, $type_field);
      foreach (keys(%{$$config{invitation}})) {
	  my $field = Volity::Jabber::Form::Field->new({var=>$_});
	  $field->values($$config{invitation}{$_});
	  push (@fields, $field);
      }
      $form->fields(@fields);
      $message->insert_tag("volity", [xmlns=>"http://volity.org/protocol/form"])->insert_tag($form);
  }
	  
  $self->post_node($message);
}

# send_query: accept a config hash, and send of a query element of a certain
# NS, maybe with a payload.
sub send_query {
    my $self = shift;
    my ($config) = @_;
    my $iq = POE::Filter::XML::Node->new('iq');
    foreach (qw(to from id type)) {
	$iq->attr($_=>$$config{$_});
    }
    my $query = $iq->insert_tag('query');
    $query->attr(xmlns=>$$config{query_ns});
    if ($$config{content}) {
	for my $kid (@{$$config{content}}) {	    
	    $query->insert_tag($kid);
	}
    }
    $self->post_node($iq);
}

sub join_muc {
  my $self = shift;
  my ($config) = @_;
  croak("You must call join_muc with an argument hashref!\n")
    unless ref($config) eq 'HASH';
  my $muc_jid;
  if ($muc_jid = $$config{jid}) {
    # We've been given the MUC's JID, but make sure there's a nick set.
    unless ($muc_jid =~ m|/.*$|) {
      if (defined($$config{nick})) {
	$muc_jid .= "/$$config{nick}";
      } else {
	  $muc_jid .= "/" . $self->user;
      }
    }
  } else {
    foreach (qw(room server nick)) {
      unless (defined($$config{$_})) {
	croak("You must specify either a full JID or a room, server, and nick in your call to join_muc().");
      }
    }
    $muc_jid = sprintf('%s@%s/%s', 
			      $$config{room}, $$config{server}, $$config{nick}
		      );
  }
  $self->logger->debug( "I want to join this muc: $muc_jid\n");
  my $presence = POE::Filter::XML::Node->new('presence');
  $presence->attr(to=>$muc_jid);
  $presence->insert_tag('x', [xmlns=>'http://jabber.org/protocol/muc']);
#  $self->post_node($presence);
  $self->send_presence({
      to=>$muc_jid,
      namespace=>'http://jabber.org/protocol/muc',
  });
  $self->logger->debug("Presence sent.\n");
  return $muc_jid;
}

sub leave_muc {
    my $self = shift;
    my ($muc_jid) = @_;
    $self->send_presence({
	to   => $muc_jid,
	type => "unavailable",
    });
}

sub send_presence {
  my $self = shift;
  my $presence = POE::Filter::XML::Node->new('presence');
  my ($config) = @_;
  $config ||= {};
  foreach (qw(to type)) {
    $presence->attr($_=>$$config{$_}) if defined($$config{$_});
  }
  foreach (qw(show status priority)) {
    $self->insert_localized_tags($presence, $_, $$config{$_}) if defined($$config{$_});
  }
  if ($$config{namespace}) {
      $presence->insert_tag('x', [xmlns=>$$config{namespace}]);
  }
  if (my $caps_config = $$config{caps}) {
      if (ref($caps_config) eq 'HASH') {
	  my $caps_node = $presence->insert_tag('c');
	  $caps_node->attr(xmlns=>"http://jabber.org/protocol/caps");
	  foreach (qw(ext node ver)) {
	      $caps_node->attr($_=>$$caps_config{$_}) if defined($$caps_config{$_});
	  }
      }
      else {
	  $self->warn("The 'caps' argument in the send_presence() method must contain a hash reference.");
      }
  }
      
  $self->post_node($presence);
}

# insert_localized_tag: internal method. Receive a POE::Filter::XML::Node object, a child
# element name, and a value that might be either a plain string or a hashref
# containing localized text keyed on langauge abbreviation. Do the right thing.
# No return value; it sticks the right elements right into the supplied
# parent node.
sub insert_localized_tags {
  my $self = shift;
  my ($parent_node, $child_name, $value) = @_;
  if (ref($value) and ref($value) eq 'HASH') {
    while (my($language, $text) = each(%$value)) {
      unless ($language =~ /^\w\w$|^\w\w-\w\w$/) {
	croak("Language must be of the form 'xx' or 'xx-xx', but you sent '$language'.");
      }
      my $tag = $parent_node->insert_tag($child_name);
      $tag->attr("xml:lang"=>$language);
      $tag->data($text);
    }
  } elsif (not(ref($value))) {
    $parent_node->insert_tag($child_name)->data($value);
  }
}

sub request_roster {
  my $self = shift;
  my $iq = POE::Filter::XML::Node->new('iq');
  $iq->attr(type=>'get');
  $iq->insert_tag('query', [xmlns=>'jabber:iq:roster']);
  $self->post_node($iq);
}

sub receive_roster {
  my $self = shift;
  my ($iq) = @_;		# POE::Filter::XML::Node object
  my $items = $iq->get_tag('query')->get_children;
  return unless defined($items);
  my $roster = Volity::Jabber::Roster->new;
  for my $item (@$items) {
    my $item_hash = {};
    foreach (qw(jid name subscription)) {
      $$item_hash{$_} = $item->attr($_) if defined($item->attr($_));
    }
    if (my $groups = $item->get_children) {
      $$item_hash{group} = [];
      for my $group (@$groups) {
	push (@{$$item_hash{group}}, $group->data)
      }
    }
    $roster->add_item($item_hash);
  }
  $self->roster($roster);
  # XXX EXPERIMENTAL
  # Send presence after receipt of roster.
  $self->send_presence;
}

sub update_roster {
  my $self = shift;
  my ($iq) = @_;		# A POE::Filter::XML::Node object
  my $item = $iq->get_tag('query')->get_tag('item');
  my $roster = $self->roster;
  unless (defined($roster)) {
    $self->error_with_node($iq, "Uh oh, got a roster-modification result from the server, but I don't have a roster set. This is bizarre.");
    return;
  }
  my $item_hash = {};
  foreach (qw(jid name subscription)) {
    $$item_hash{$_} = $item->attr($_) if defined($item->attr($_));
  }
  if (my @groups = $item->get_children) {
    $$item_hash{group} = [];
    for my $group (@groups) {
      # XXX ?!
	eval {push (@{$$item_hash{group}}, $group->data)};
	warn "Whoa, burped with $group" if $@;
    }
  }
  # Now that we've made a chewable data structure from this item,
  # figure out how it applies to the roster.
  # As it happens, we _always_ want to remove this item from the roster,
  # as a first step. If it's an add or an update, we'll just re-add it,
  # with this new item data.
  $roster->remove_item($$item_hash{jid});
  if ($$item_hash{subscription} ne 'remove') {
    # OK, so it's either an add or an update.
    # In either case, we will add it this new data to the roster.
    $roster->add_item($item_hash);
  }
}

sub request_disco_info {
  my $self = shift;
  my ($info) = @_;
  my $iq = POE::Filter::XML::Node->new('iq');
  $iq->attr(type=>'get');
  if (not($info) or not(ref($info) eq 'HASH')) {
    croak("You must call request_disco with a hashref argument.");
  }
  unless ($$info{to}) {
    croak("The hash argument to request_disco() must contain at least a 'to' key, with a JID value.");
  }
  $iq->attr(to=>$$info{to});
  $iq->attr(id=>$$info{id}) if defined($$info{id});
  my $query = $iq->insert_tag('query', [xmlns=>"http://jabber.org/protocol/disco#info"]);
  $query->attr(node=>$$info{node}) if defined($$info{node});
  $self->post_node($iq);
}

sub request_disco_items {
  my $self = shift;
  my ($info) = @_;
  my $iq = POE::Filter::XML::Node->new('iq');
  $iq->attr(type=>'get');
  if (not($info) or not(ref($info) eq 'HASH')) {
    croak("You must call request_disco with a hashref argument.");
  }
  unless ($$info{to}) {
    croak("The hash argument to request_disco() must contain at least a 'to' key, with a JID value.");
  }
  $iq->attr(to=>$$info{to});
  $iq->attr(id=>$$info{id}) if defined($$info{id});
  my $query = $iq->insert_tag('query', [xmlns=>"http://jabber.org/protocol/disco#items"]);
  $query->attr(node=>$$info{node}) if defined($$info{node});
  $self->post_node($iq);
}


sub receive_disco_info {
  my $self = shift;
  $self->handle_disco_info($self->receive_disco(@_));
}

sub receive_disco_items {
  my $self = shift;
  $self->handle_disco_items($self->receive_disco(@_));
}

# Stubs, to override.
sub handle_disco_items { }
sub handle_disco_info { }

sub handle_disco_items_request { }
sub handle_disco_info_request { }

# receive_disco:
# Given a disco-response IQ, return its origin JID, the IQ's ID,
# a listref of disco items, and a hashref of JEP-0128 form fields.
sub receive_disco {
  my $self = shift;
  my ($iq) = @_;
  my @return = ($iq->attr('from'), $iq->attr('id'));
  my (@items, %fields);
  for my $child (@{$iq->get_tag('query')->get_children}) {
      if ($child->name eq 'x') {
	  for my $field ($child->get_tag('field')) {
	      next unless (ref($field));
	      bless ($field, "Volity::Jabber::Form::Field");
	      $fields{$field->var} = [$field->values];
	  }
      } else {
	  my $class = "Volity::Jabber::Disco::" . ucfirst($child->name);
	  bless($child, $class);
	  push (@items, $child);
      }
  }
  push (@return, \@items, \%fields);
  return @return;
}

sub send_disco_items {
  my $self = shift;
  $self->send_disco('items', @_);
}

sub send_disco_info {
  my $self = shift;
  $self->send_disco('info', @_);
}

sub send_disco {
    my $self = shift;
    my ($type, $info) = @_;
    if (not($info) or not(ref($info) eq 'HASH')) {
	croak("You must call send_disco_$type with a hashref argument.");
    }
    
#    my $iq = POE::Filter::XML::Node->new('iq');
#    $iq->attr(type=>'result');
#    $iq->attr(id=>$$info{id}) if (defined($$info{id}));
#    if ($$info{to}) {
#	$iq->attr(to=>$$info{to});
#    } else {
#	$self->expire("The hash argument to send_disco_$type contain at least a 'to' key, with a JID value.");
#    }
    
#    my $query = $iq->insert_tag('query', [xmlns=>"http://jabber.org/protocol/disco#$type"]);
    
    my @query_content;

    if (defined($$info{items})) {
	my @items_to_add = ref($$info{items})? @{$$info{items}} : ($$info{items});
	for my $item (@items_to_add) {
	    unless ($item->isa("Volity::Jabber::Disco::Node")) {
		croak("The items you add must be objects belonging to one of the Volity::Jabber::Disco::* classes. But you passed me this: $item");
	    }
#	    $query->insert_tag($item);
	    push (@query_content, $item);
	}
    }
    
    # There may also be a data form, as per JEP-0128.
    if (defined($$info{fields})) {
	my $form = Volity::Jabber::Form->new({type=>'result'});
	my @fields_to_add = ref($$info{fields})? @{$$info{fields}} : ($$info{fields});
	for my $field (@fields_to_add) {
	    unless ($field->isa("Volity::Jabber::Form::Field")) {
		croak("The fields you add must be objects belonging to the Volity::Jabber::Form::Field class. But you passed me this: $field");
	    }
	}
	$form->fields(@fields_to_add);
	push (@query_content, $form);
    }

#    $self->post_node($iq);
    $self->send_query({
	to=>$$info{to},
	id=>$$info{id},
	type=>'result',
	content=>\@query_content,
	query_ns=>"http://jabber.org/protocol/disco#$type",
    });
}

sub send_registration {
  my $self = shift;
  my ($config) = @_;
  my $iq = POE::Filter::XML::Node->new('iq');
  $iq->attr(type=>'set');
  $$config{id} ||= $self->next_id;
  $iq->attr(id=>$$config{id});
  my $query = $iq->insert_tag('query', [xmlns=>'jabber:iq:register']);
  foreach (keys(%$config)) {
    next if $_ eq 'id';
    $query->insert_tag($_)->data($$config{$_});
  }
  $self->set_iq_notification($$config{id}, 
			     {result=>'handle_registration_result'});
  $self->post_node($iq);
}

sub send_unregistration {
  my $self = shift;
  my ($id) = @_;
  $id ||= $self->next_id;
  my $iq = POE::Filter::XML::Node->new('iq');
  $iq->attr(type=>'set');
  $iq->attr(id=>$id) if defined($id);
  my $query = $iq->insert_tag('query', [xmlns=>'jabber:iq:register']);
  $query->insert_tag('remove');
  $self->set_iq_notification($id, 
			     {result=>'handle_unregistration_result'});
  $self->post_node($iq);
}  

sub handle_registration_result { }

sub handle_unregistration_result { }

sub receive_registration_error {
  my $self = shift;
  my ($iq) = @_;
  my $error = $iq->get_tag('error');
  $self->handle_registration_error(
				   {
				    id=>$iq->attr('id'),
				    error_node=>$error,
				    code=>$error->attr('code'),
				    type=>$error->attr('type'),
				    message=>$error->data,
				   }
				  );
}

# Stub:
sub handle_registration_error { }

# send_form: This doesn't actually work. You'll note that the incoming $form
# variable get validated but never used.
# Repair this once this method needs to become useful. --jmac 08/2006
sub send_form {
    my $self = shift;
    my ($config) = @_;
    my $form = $$config{form};
    unless ($form->isa("Volity::Jabber::Form")) {
	Carp::croak("The argument to send_form must be an object of class Volity::Jabber::Form.");
      }
    my $iq = POE::Filter::XML::Node->new('iq');
    foreach (qw(to id)) {
	$iq->attr($_=>$$config{$_}) if defined($$config{$_});
    }
    $iq->attr(type=>'set');
    $self->post_node($iq);
}

sub disconnect {
    my $self = shift;
    $self->send_presence({type=>'unavailable'});
    $self->kernel->post($self->alias, 'shutdown_socket', 0);
}

###########################
# Special accessors
###########################

# basic_jid: Return the non-resource part of my JID.
sub basic_jid {
  my $self = shift;
  if (defined($self->jid) and $self->jid =~ /^(.*)\//) {
    return $1;
  }
  return undef;
}

package Volity::Jabber::Roster;

use warnings;
use strict;
use base qw(Volity);
use fields qw(jids groups names_by_jid jids_by_name groups_by_jid presence);
use Carp qw(carp croak);

sub initialize {
  my $self = shift;
  $self->{groups}->{_NONE} = [];
  $self->{names_by_jid} = {};
  $self->{jids_by_name} = {};
  return $self;
}

sub add_item {
  my $self = shift;
  my ($item_hash) = @_;
  $$item_hash{group} ||= ['_NONE'];
  $$item_hash{group} = [$$item_hash{group}] unless ref($$item_hash{group});
  my @current_groups_of_this_jid = $self->groups_for_jid($$item_hash{jid});
  for my $group_name (@{$$item_hash{group}}) {
    $group_name ||= '_NONE';
    $self->{groups}->{$group_name} ||= [];
    $self->{groups}->{$$item_hash{group}}->{$$item_hash{jid}} = 1;
    $self->{groups_by_jid}->{$$item_hash{jid}} ||= [];
    push (@{$self->{groups_by_jid}->{$$item_hash{jid}}}, $group_name);
  }
  if (defined($$item_hash{name})) {
    $self->{jids_by_name}->{$$item_hash{name}} = $$item_hash{jid};
    $self->{names_by_jid}->{$$item_hash{jid}} = $$item_hash{name};
  }
  $self->{jids}->{$$item_hash{jid}} = 1;
}

sub remove_item {
  my $self = shift;
  my ($jid) = @_;
  # XXX A JID-syntax check would be nice here.
  unless (defined($jid)) {
    croak("You must call remove_item with a JID.");
  }
  if (defined($self->{names_by_jid}->{$jid})) {
    delete($self->{jids_by_name}->{delete($self->{names_by_jid}->{$jid})});
  }
  for my $group_name ($self->groups_for_jid($jid)) {
    delete($self->{groups}->{$group_name}->{$jid});
  }
  delete($self->{groups_by_jid}->{$jid});
  delete($self->{jids}->{$jid});
}

sub jids {
  my $self = shift;
  return keys(%{$self->{jids}});
}

sub ungrouped_jids {
  my $self = shift;
  return keys(%{$self->{groups}->{_NONE}});
}

sub jids_in_group {
  my $self = shift;
  my ($group) = @_;
  unless (defined($group)) {
    croak("You must call jids_in_group with a group name.");
  }
  if (defined($self->{groups}->{$group})) {
    return keys(%{$self->{groups}->{$group}});
  }
}

sub jid_for_name {
  my $self = shift;
  my ($name) = @_;
  unless (defined($name)) {
    croak("You must call jid_for_name with a name to look up.");
  }
  return $self->{jids_by_name}->{$name};
}

sub name_for_jid {
  my $self = shift;
  my ($jid) = @_;
  unless (defined($jid)) {
    croak("You must call name_for_jid with a JID to look up.");
  }
  return $self->{names_by_jid}->{$jid};
}

sub groups_for_jid {
  my $self = shift;
  my ($jid) = @_;
  unless (defined($jid)) {
    croak("You must call groups_for_jid with a JID.");
  }
  if (defined($self->{groups_by_jid}->{$jid})) {
    return @{$self->{groups_by_jid}->{$jid}};
  } else {
    return ();
  }
}

sub has_jid {
  my $self = shift;
  my ($jid) = @_;
  my $resource;
  ($jid, $resource) = $jid =~ m{^([^/]+)(?:/(.*))?$}
    or croak "Could not find jid and resource in $_[0]\n";
  if (exists($self->{jids}->{$jid})) {
    return 1;
  } else {
    return 0;
  }
}

# presence: get or set a hashful of information about the given JID's presence.
# Note that the roster object doesn't listen to presence and do this all by
# itself; this method has to be called from outside.
sub presence {
  my $self = shift;
  my ($jid, $presence_hash) = @_;
  my $resource;
  ($jid, $resource) = $jid =~ /^(.*?)(?:\/(.*))?$/;
  if ($presence_hash) {
    if (defined($resource)) {
      $self->{presence}->{$jid}->{resources}->{$resource} = $presence_hash;
    } else {
      $self->{presence}->{$jid}->{general} = $presence_hash;
    }
  }
  my @presence_list;
  for my $resource (keys(%{$self->{presence}->{$jid}->{resources}})) {
    my $presence_hash = $self->{presence}->{$jid}->{resources}->{$resource};
    $$presence_hash{resource} = $resource;
#    $$presence_hash{jid} = $jid;
    push (@presence_list, $presence_hash);
  }
  push (@presence_list, $self->{presence}->{$jid}->{general}) if defined $self->{presence}->{$jid}->{general};
#  use Data::Dumper;
#  die Dumper(\@presence_list);
  
  return @presence_list;
}

package Volity::Jabber::Disco::Node;
use warnings; use strict;
use base qw(POE::Filter::XML::Node Class::Accessor);

sub new {
  my $class = shift;
  my ($node_type) = $class =~ /^.*::(.*?)$/;
  my $self = POE::Filter::XML::Node->SUPER::new(lc($node_type));
  bless ($self, $class);
  my ($init_hash) = @_;
  while (my($key, $val) = each(%$init_hash)) {
    if ($self->can($key)) {
      $self->$key($val);
    } else {
      $self->expire("I can't call the $key accessor on a $class object.");
    }
  }
  return $self;
}

sub set {
  my $self = shift;
  my ($key, $value) = @_;

  if (defined($value)) {
      # Apply XML escapes to the given value.
      $value =~ s/&/&/g;
      $value =~ s/</&lt;/g;
      $value =~ s/>/&gt;/g;
      $value =~ s/'/&apos;/g;
      $value =~ s/"/&quot;/g;
  }

  # Now make it an attribute on the current object.
  $self->attr($key=>$value);
  return $value;
}

sub get {
    my $self = shift;
    my ($key) = @_;
    return $self->attr($key);
}

package Volity::Jabber::Disco::Item;

use warnings; use strict;
use base qw(Volity::Jabber::Disco::Node);

__PACKAGE__->mk_accessors(qw(jid node name));

package Volity::Jabber::Disco::Identity;

use warnings; use strict;
use base qw(Volity::Jabber::Disco::Node);

__PACKAGE__->mk_accessors(qw(category type name));

package Volity::Jabber::Disco::Feature;

use warnings; use strict;
use base qw(Volity::Jabber::Disco::Node);

__PACKAGE__->mk_accessors(qw(var));

package Volity::Jabber::Form;

use warnings; use strict;
use base qw(Volity::Jabber::Disco::Node);

__PACKAGE__->mk_accessors(qw(type title instructions));

# Define which accessors get child elements, not attributes.
our %elements = (
		 title=>1,
		 instructions=>1,
		 );

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->attr(xmlns=>"jabber:x:data");
    $self->name('x');
    return $self;
}

sub set {
    my $self = shift;
    my ($key, $value) = @_;
    if (exists($elements{$key})) {
	my $kid = $self->get_tag($key);
	unless ($kid) {
	    $kid = $self->insert_tag($key);
	}
	$kid->data($value);
    } else {
	return $self->SUPER::set(@_);
    }
}

sub get {
    my $self = shift;
    my ($key) = @_;
    if (exists($elements{$key})) {
	if (my $kid = $self->get_tag($key)) {
	    return $kid->data;
	} else {
	    return undef;
	}
    } else {
	return $self->SUPER::get(@_);
    }
}

sub fields {
    my $self = shift;
    my @fields = @_;
    if (@fields) {
	$self->clear_fields;
	if (grep(not($_->isa("Volity::Jabber::Form::Field")), @fields)) {
	    die "Arguments to fields() must all be Volity::Jabber::Form::Field  objects. I got these instead: @fields";
	}
	foreach (@fields) { $self->insert_tag($_) }
    }
    my @return_fields = map(bless($_, "Volity::Jabber::Form::Field"), grep(defined($_), $self->get_tag('field')));
    return @return_fields;
}

sub clear_fields {
    my $self = shift;
    for my $field (grep(defined($_), $self->get_tag('field'))) {
	$self->detach_child($field);
    }
}

sub invalid_fields {
    my $self = shift;
    return grep(not($_->is_valid), $self->fields);
}

package Volity::Jabber::Form::Field;

use warnings; use strict;
use base qw(Volity::Jabber::Disco::Node);

__PACKAGE__->mk_accessors(qw(label var type));

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->name('field');
    return $self;
}

sub desc {
    my $self = shift;
    my $desc_node = $self->get_tag('desc');
    if (exists($_[0])) {
	my ($desc) = @_;
	$self->detach_child($desc_node) if defined($desc_node);
	$self->insert_tag('desc')->data($desc);
	return $desc;
    } else {
	if (defined($desc_node)) {
	    return $desc_node->data;
	} else {
	    return undef;
	}
    }
}
	
sub is_required {
    my $self = shift;
    my ($required) = @_;
    if (defined($required)) {
	if ($required) {
	    $self->insert_tag('required') unless $self->get_tag('required');
	} else {
	    if (my $tag = $self->get_tag('required')) {
		$self->detach_child($tag);
	    }
	}
    }
    if ($self->get_tag('required')) {
	return 1;
    } else {
	return 0;
    }
}

sub is_valid {
    my $self = shift;
    if ($self->is_required and not($self->values)) {
	return 0;
    } else {
	return 1;
    }
}
       

# values: Accessor to this field's value elements.
# Always returns a list of the current values, as simple strings.
sub values {
    my $self = shift;
    my (@values) = @_;
    if (@values) {
	$self->clear_values;
	for my $value (@values) {
	    $self->insert_tag('value')->data($value);
	}
	return $self;
    } else {
	@values = map($_->data, grep(defined($_), $self->get_tag('value')));
    }
    return @values;
}

# Each member of the @options argument is a hashref with two keys:
# label: the label of this option
# values: scalar or anon. array of values.
sub options {
    my $self = shift;
    my (@options) = @_;
    if (@options) {
	$self->clear_options;
	for my $option (@options) {
	    my $label = $$option{label};
	    my @values;
	    if ($$option{values}) {
		if (ref($$option{values})) {
		    @values = @{$$option{values}};
		} else {
		    @values = ($$option{values});
		}
	    }
	    my $option = $self->insert_tag('option');
	    $option->attr(label=>$label);
	    foreach (@values) { $option->insert_tag('value')->data($_) }
	}
    } else {
	for my $option_node ($self->get_tag('option')) {
	    my $label = $option_node->attr('label');
	    my @values = $option_node->get_tag('value');
	    push (@options, {label=>$label, values=>\@values});
	}
    }
    return @options;
}


# clear_values: Drop all the value elements.
sub clear_values {
    my $self = shift;
    map ($self->detach_child($_), grep(defined($_), $self->get_tag('value')));
}

sub clear_options {
    my $self = shift;
    map ($self->detach_child($_), grep(defined($_), $self->get_tag('option')));
}

################################
####### POSTSCRIPT (docs only after this point)
################################

1;