package AnyEvent::XMPP::Ext::MUC::Room;
use strict;
no warnings;
use AnyEvent::XMPP::Namespaces qw/xmpp_ns/;
use AnyEvent::XMPP::Util qw/
bare_jid prep_bare_jid cmp_jid split_jid join_jid is_bare_jid
prep_res_jid prep_join_jid resourceprep
/;
use AnyEvent::XMPP::Ext::MUC::User;
use AnyEvent::XMPP::Ext::DataForm;
use AnyEvent::XMPP::Error::MUC;
use constant {
JOIN_SENT => 1,
JOINED => 2,
LEFT => 3,
};
=head1 NAME
AnyEvent::XMPP::Ext::MUC::Room - Room class
=head1 SYNOPSIS
=head1 DESCRIPTION
This module represents a room handle for a MUC.
=head1 METHODS
=over 4
=item B<new (%args)>
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = bless { status => LEFT, @_ }, $class;
$self->init;
$self
}
sub init {
my ($self) = @_;
$self->{jid} = bare_jid ($self->{jid});
}
sub event {
my ($self, $ev, @args) = @_;
$self->{muc}->event ($ev, $self, @args);
}
sub handle_message {
my ($self, $node) = @_;
my $msg = AnyEvent::XMPP::Ext::MUC::Message->new (room => $self);
if ($node->attr ('type') eq 'error') {
my $error =
AnyEvent::XMPP::Error::MUC->new (
message_node => $node,
message => $msg
);
if ($error->type eq 'subject_change_forbidden') {
$self->event (subject_change_error => $error);
} else {
$self->event (message_error => $error);
}
} else {
$msg->from_node ($node);
my $is_echo = cmp_jid ($msg->from, $self->nick_jid)
&& $msg->type eq 'groupchat';
if (not (defined $msg->any_body)
&& defined $msg->any_subject) { # subject change
$self->event (subject_change => $msg, $is_echo);
return;
}
$self->event (message => $msg, $is_echo);
}
}
sub handle_presence {
my ($self, $node) = @_;
my $s = $self->{status};
my $from = $node->attr ('from');
my $type = $node->attr ('type');
my $error;
if ($type eq 'error') {
$error = AnyEvent::XMPP::Error::Presence->new (node => $node);
}
my $stati = {};
my $new_nick;
if (my ($x) = $node->find_all ([qw/muc_user x/])) {
for ($x->find_all ([qw/muc_user status/])) {
$stati->{$_->attr ('code')}++;
}
if (my ($i) = $x->find_all ([qw/muc_user item/])) {
$new_nick = $i->attr ('nick');
}
}
my $nick_change = $stati->{'303'};
if ($s == JOIN_SENT) {
if ($error) {
my $muce = AnyEvent::XMPP::Error::MUC->new (
presence_error => $error,
type => 'presence_error'
);
$self->event (join_error => $muce);
} else {
if (cmp_jid ($from, $self->nick_jid)) {
my $user = $self->add_user_xml ($node);
$self->{status} = JOINED;
$self->{me} = $user;
if ($user->did_create_room) {
if ($self->{locked_cb}) {
(delete $self->{locked_cb})->($self);
} else {
$self->event ('locked');
}
} else {
$self->event (enter => $user);
}
} else {
$self->add_user_xml ($node);
}
}
} elsif ($s == JOINED) { # nick changes?
if ($error) {
my $muce = AnyEvent::XMPP::Error::MUC->new (
presence_error => $error,
type => 'presence_error'
);
$self->event (error => $muce);
} elsif (!$nick_change && $type eq 'unavailable') {
if (cmp_jid ($from, $self->nick_jid)) {
$self->event ('leave', $self->get_me);
$self->we_left_room ();
} else {
my $nick = prep_res_jid ($from);
my $user = delete $self->{users}->{$nick};
if ($user) {
$user->update ($node);
$self->event (part => $user);
} else {
warn "User with '$nick' not found in room $self->{jid}!\n";
}
}
} elsif ($nick_change && $type eq 'unavailable') {
my $nick = prep_res_jid ($from);
my $nnick = resourceprep ($new_nick);
my $user = $self->{users}->{$nnick} = delete $self->{users}->{$nick};
if ($user) {
$user->update ($node);
$self->event (nick_change_leave => $user, $nick, $new_nick);
} else {
warn "User with '$nick' not found in room $self->{jid} for nickchange!\n";
}
} else {
my $nick = prep_res_jid $from;
my $pre = $self->{users}->{$nick};
my $in_nick_change = $pre ? $pre->is_in_nick_change : undef;
my $user = $self->add_user_xml ($node);
if ($pre) {
if ($in_nick_change) {
$self->event (nick_change => $user, $user->{old_nick}, $user->nick);
} else {
$self->event (presence => $user);
}
} else {
$self->event (join => $user);
}
}
}
}
sub we_left_room {
my ($self) = @_;
$self->{users} = {};
$self->{status} = LEFT;
delete $self->{me};
}
=item B<get_user ($nick)>
This method returns the user with the C<$nick> in the room.
=cut
sub get_user {
my ($self, $nick) = @_;
$self->{users}->{$nick}
}
=item B<get_me>
This method returns the L<AnyEvent::XMPP::Ext::MUC::User> object of yourself
in the room. If will return undef if we are not in the room anymore.
=cut
sub get_me {
my ($self) = @_;
$self->{me}
}
=item B<get_user_jid ($jid)>
This method looks whether a user with the JID C<$jid> exists
in the room. That means whether the node and domain part of the
JID match the rooms node and domain part, and the resource part of the
JID matches a joined nick.
=cut
sub get_user_jid {
my ($self, $jid) = @_;
my ($room, $srv, $nick) = split_jid ($jid);
return unless prep_join_jid ($room, $srv) eq prep_bare_jid $self->jid;
$self->{users}->{$nick}
}
=item B<get_users>
This method returns the list of occupants as L<AnyEvent::XMPP::Ext::MUC::User> objects.
=cut
sub get_users {
my ($self) = @_;
values %{$self->{users}};
}
sub add_user_xml {
my ($self, $node) = @_;
my $from = $node->attr ('from');
my $nick = prep_res_jid ($from);
my $user = $self->{users}->{$nick};
unless ($user) {
$user = $self->{users}->{$nick} =
AnyEvent::XMPP::Ext::MUC::User->new (room => $self);
}
$user->update ($node);
$user
}
sub _join_jid_nick {
my ($jid, $nick) = @_;
my ($node, $host) = split_jid $jid;
join_jid ($node, $host, $nick);
}
sub check_online {
my ($self) = @_;
unless ($self->is_connected) {
warn "room $self not connected anymore!";
return 0;
}
1
}
sub send_join {
my ($self, $nick, $password, $history) = @_;
$self->check_online or return;
$self->{nick_jid} = _join_jid_nick ($self->{jid}, $nick);
$self->{status} = JOIN_SENT;
my @chlds;
if (defined $password) {
push @chlds, { name => 'password', childs => [ $password ] };
}
if (defined $history) {
my $h;
push @{$h->{attrs}}, ('maxchars', $history->{chars})
if defined $history->{chars};
push @{$h->{attrs}}, ('maxstanzas', $history->{stanzas})
if defined $history->{stanzas};
push @{$h->{attrs}}, ('seconds', $history->{seconds})
if defined $history->{seconds};
if (defined $h->{attrs}) {
$h->{name} = 'history';
push @chlds, $h;
}
}
my $con = $self->{connection};
$con->send_presence (undef, {
defns => 'muc', node => { ns => 'muc', name => 'x', childs => [ @chlds ] }
}, to => $self->{nick_jid});
}
=item B<make_instant ($cb)>
If you just created a room you can create an instant room with this
method instead of going through room configuration for a reserved room.
If you want to create a reserved room instead don't forget to unset the
C<create_instant> argument of the C<join_room> method of L<AnyEvent::XMPP::Ext::MUC>!
See also the C<request_configuration> method below for the reserved room config.
C<$cb> is the callback that will be called when the instant room creation is
finished. If successful the first argument will be this room object
(C<$self>), if unsuccessful the first argument will be undef and the second
will be a L<AnyEvent::XMPP::Error::IQ> object.
=cut
sub make_instant {
my ($self, $cb) = @_;
$self->check_online or return;
my $df = AnyEvent::XMPP::Ext::DataForm->new;
$df->set_form_type ('submit');
my $sxl = $df->to_simxml;
$self->{connection}->send_iq (
set => {
defns => 'muc_owner', node => {
name => 'query', childs => [ $sxl ]
}
}, sub {
my ($n, $e) = @_;
if ($e) {
$cb->(undef, $e);
} else {
$cb->($self, undef);
}
},
to => $self->jid
);
}
=item B<request_configuration ($cb)>
This method requests the room configuration. When the configuration
form or an error arrives C<$cb> will be called.
The first argument to the callback will be a L<AnyEvent::XMPP::Ext::DataForm>
with the room configuration form or undef in case of an error.
The second argument will be a L<AnyEvent::XMPP::Error::MUC> error object if an
error occurred or undef if no error occurred.
If you made an answer form you can send it via the C<send_configuration>
method below.
Here is an example:
$room->request_configuration (sub {
my ($form, $err) = @_;
$form or return;
my $af = AnyEvent::XMPP::Ext::DataForm->new;
$af->make_answer_form ($form);
$af->set_field_value ('muc#roomconfig_maxusers', 20);
$af->clear_empty_fields;
$roomhdl->send_configuration ($af, sub {
# ...
});
});
=cut
sub request_configuration {
my ($self, $cb) = @_;
$self->check_online or return;
$self->{connection}->send_iq (
get => {
defns => 'muc_owner', node => { name => 'query' }
}, sub {
my ($n, $e) = @_;
if ($n) {
if (my ($x) = $n->find_all ([qw/muc_owner query/], [qw/data_form x/])) {
my $form = AnyEvent::XMPP::Ext::DataForm->new;
$form->from_node ($x);
$cb->($form, undef);
} else {
$e = AnyEvent::XMPP::Error::MUC->new (
type => 'no_config_form',
text => "The room didn't provide a configuration form"
);
$cb->(undef, $e);
}
} else {
$cb->(undef, $e);
}
},
to => $self->jid
);
}
=item C<send_configuration ($answer_form, $cb)>
This method sends the answer form to a configuration request to the room.
C<$answer_form> should be a L<AnyEvent::XMPP::Ext::DataForm> object containig the
answer form with the changed configuration.
The first argument of C<$cb> will be a true value if the configuration change
was successful. The second argument of C<$cb> will be a C<AnyEvent::XMPP::Error::IQ>
object if the configuration change was not successful.
=cut
sub send_configuration {
my ($self, $form, $cb) = @_;
$self->check_online or return;
$self->{connection}->send_iq (
set => {
defns => 'muc_owner', node => { name => 'query', childs => [
$form->to_simxml
]}
}, sub {
my ($n, $e) = @_;
if ($e) {
$cb->(undef, $e);
} else {
$cb->(1, undef);
}
},
to => $self->jid
);
}
sub message_class { 'AnyEvent::XMPP::Ext::MUC::Message' }
=item B<make_message (%args)>
This method constructs a L<AnyEvent::XMPP::Ext::MUC::Message> with
a connection to this room.
C<%args> are further arguments for the constructor of L<AnyEvent::XMPP::Ext::MUC::Message>.
The default C<to> argument for the message is the room and the
C<type> will be 'groupchat'.
=cut
sub make_message {
my ($self, %args) = @_;
$self->message_class ()->new (
room => $self,
to => $self->jid,
type => 'groupchat',
%args
)
}
=item B<send_part ($msg, $cb, $timeout)>
This lets you part the room, C<$msg> is an optional part message
and can be undef if no custom message should be generated.
C<$cb> is called when we successfully left the room or after
C<$timeout> seconds. The default for C<$timeout> is 60.
The first argument to the call of C<$cb> will be undef if
we successfully parted, or a true value when the timeout hit.
Even if we timeout we consider ourself parted (and a 'leave' event
is generated).
=cut
sub send_part {
my ($self, $msg, $cb, $timeout) = @_;
$self->check_online or return;
$timeout ||= 60;
my $con = $self->{connection};
my $timeouted = 0;
if ($cb) {
$self->{_part_timeout} =
AnyEvent->timer (after => $timeout, cb => sub {
delete $self->{_part_timeout};
$timeouted = 1;
$self->event ('leave', $self->get_me);
});
$self->{muc}->reg_cb (ext_after_leave => sub {
my ($muc, $room) = @_;
return unless cmp_jid ($room->nick_jid, $self->nick_jid);
delete $self->{_part_timeout};
$cb->($timeouted) if $cb;
$muc->unreg_me;
});
}
$con->send_presence (
'unavailable', undef,
(defined $msg ? (status => $msg) : ()),
to => $self->{nick_jid}
);
}
=item B<users>
Returns a list of L<AnyEvent::XMPP::Ext::MUC::User> objects
which are in this room.
=cut
sub users {
my ($self) = @_;
values %{$self->{users}}
}
=item B<jid>
Returns the bare JID of this room.
=cut
sub jid { $_[0]->{jid} }
=item B<nick_jid>
Returns the full JID of yourself in the room.
=cut
sub nick_jid { $_[0]->{nick_jid} }
=item B<is_connected>
Returns true if this room is still connected (but maybe not joined (yet)).
=cut
sub is_connected {
my ($self) = @_;
$self->{muc} && $self->{connection} && $self->{connection}->is_connected
}
=item B<connection>
If the room is still joined this method will return the connection
on which the room is connected.
=cut
sub connection {
my ($self) = @_;
$self->{connection}
}
=item B<is_joined>
Returns true if this room is still joined (and connected).
=cut
sub is_joined {
my ($self) = @_;
$self->is_connected
&& $self->{status} == JOINED
}
=item B<change_nick ($newnick)>
This method lets you change your nickname in this room.
=cut
sub change_nick {
my ($self, $newnick) = @_;
my ($room, $srv) = split_jid $self->jid;
$self->{connection}->send_presence (
undef, undef, to => join_jid ($room, $srv, $newnick)
);
}
=item B<change_subject ($newsubject)>
This methods changes the subject of the room.
=cut
sub change_subject {
my ($self, $newsubject) = @_;
my $msg = $self->make_message (subject => $newsubject);
$msg->send;
}
=back
=head1 AUTHOR
Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
=head1 COPYRIGHT & LICENSE
Copyright 2007, 2008 Robin Redeker, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1;