view release on metacpan or  search on metacpan

lib/Net/Chat/Daemon.pm  view on Meta::CPAN

  }

  my %commands;
  @commands{keys %{ $self->{commands} }} = ();

  no strict 'refs';
  foreach (map { s/handle//; "\l$_" }
           grep { *{${ref($self)."::"}{$_}}{CODE} }
           grep { /^handle/ }
           keys %{ref($self)."::"})
  {
    $commands{$_} = 1;
  }

  return "Available commands: " . join(" ", sort keys %commands);
}

=item B<onRequest>($msg, %extra)

This method will be invoked as a callback whenever a request is
received. As you know if you've read the documentation for
C<onMessage> and C<onReply>, by default all messages go through this
handler.

The default implementation of onRequest parses the message into a
command and an array of arguments, looks up the appropriate handler
for that command, invokes the handler with the arguments, then sends
back a reply message with the return value of the handler as its text.

If any files are attached to the message, they are extracted and
appended to the end of the argument list.

An example: if you send the message "register me@jabber.org ALL" to
the server, it will look up its internal command map. If you defined a
C<handleRegister> method, it will call that. Otherwise, if you
specified the command 'register' in the commands hash, it will call
whatever value if finds there. Two arguments will be passed to the
handler: the string "me@jabber.org", and the string "ALL".

=cut

sub onRequest {
  my ($self, $message) = @_;
  my $body = $message->GetBody();
  my $from = $message->GetFrom();
  $self->_log(1, "[$self->{user}] from($from): $body\n");

  # Parse the request body into a command and a list of arguments
  my ($cmd, @args) = $body =~ /('(?:\\.|.)*'|"(?:\\.|.)*"|\S+)/g;
  foreach (@args) {
    $_ = substr($_, 1, -1) if (/^['"]/);
  }

  # Add the attachments to the end of the @args array. This is most
  # likely an abuse of the Jabber protocol.
  my $attachments_node = $message->{TREE}->XPath("attachments");
  my @attachments = $attachments_node ? $attachments_node->children() : ();
  foreach my $node (@attachments) {
    my %attachment;
    foreach ($node->children()) {
      $attachment{$_->get_tag()} = $_->get_cdata();
    }
    push @args, \%attachment;
  }

  # Lookup the handler for this command and call it, then send back
  # the result as a reply.
  my $meth = $self->getHandler($cmd);
  my $reply = $message->Reply();
  local $self->{last_message} = $message;
  if ($meth) {
    if (UNIVERSAL::isa($meth, 'CODE')) {
      $reply->SetBody($meth->(@args));
    } else {
      $reply->SetBody($self->$meth(@args));
    }
    $self->{cxn}->Send($reply);
    return 1;
  } else {
    $self->_log(0, "[$self->{user}] ignoring message: $body");
    return;
  }
}

=item B<checkMaster>($sid, $presence)

Internal: presence unavailable callback - exit if the master exited

=cut

sub checkMaster {
  my ($self, $sid, $presence) = @_;
  if ($self->{master} eq $presence->GetFrom("jid")->GetUserID()) {
    $self->_log(0, "[$self->{user}] master terminated, exiting.");
    exit 0;
  }
  return;
}

=item B<process>([$timeout])

Wait $timeout seconds for more messages to come in. If $timeout is not
given or undefined, block until a message is received.

Return value: 1 = data received, 0 = ok but no data received, undef = error

=cut

sub process {
  my $self = shift;
  return $self->{cxn}->wait(@_);
}

################## SYNCHRONIZATION METHODS #####################

sub _makeId {
  return time();
}

=item B<waitUntilAllHere>($nodes)