Permalink
Browse files

added initial_presence argument to the IM::Connection and the

Client. added and upgraded some examples. further work on the
registration forms.
  • Loading branch information...
1 parent 60d82ba commit 22cf02c37333d49aec8e2fc804e10e38832282b4 elmex committed Jul 19, 2007
View
@@ -1,6 +1,11 @@
Revision history for Net-XMPP2
0.03
+ - reordered events a bit so that session_ready comes after
+ roster retrieval (when it is retrieved)
+ - added possibility to set the initial presence priority
+ or prevent sending of initial presence
+ (see Net::XMPP2::IM::Connection).
- fixed some minor issue with handling invalid disco results
- added send_*_hook event hooks for future extensions
like the entity capabilities to be able to add payload
View
@@ -148,7 +148,15 @@ sub update_connections {
for my $acc (values %{$self->{accounts}}) {
unless ($acc->is_connected) {
- my $con = $acc->spawn_connection;
+ my %args = (initial_presence => 10);
+
+ if (defined $self->{presence}) {
+ if (defined $self->{presence}->{priority}) {
+ $args{initial_presence} = $self->{presence}->{priority};
+ }
+ }
+
+ my $con = $acc->spawn_connection (%args);
$con->add_forward ($self, sub {
my ($con, $self, $ev, @arg) = @_;
@@ -159,6 +167,9 @@ sub update_connections {
session_ready => sub {
my ($con) = @_;
$self->event (connected => $acc);
+ if (defined $self->{presence}) {
+ $con->send_presence (undef, undef, %{$self->{presence} || {}});
+ }
0 # do once
},
# debug_recv => sub { print "RRRRRRRRECVVVVVV:\n"; _dumpxml ($_[1]); 1 },
@@ -403,14 +414,15 @@ C<send_presence> method of L<Net::XMPP2::Writer>.
sub set_presence {
my ($self, $show, $status, $priority) = @_;
+ $self->{presence} = {
+ show => $show,
+ status => $status,
+ priority => $priority
+ };
+
for my $ac ($self->get_connected_accounts) {
my $con = $ac->connection ();
- $con->send_presence (
- undef, undef,
- show => $show,
- status => $status,
- priority => $priority
- );
+ $con->send_presence (undef, undef, %{$self->{presence}});
}
}
@@ -60,15 +60,105 @@ sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = bless { @_ }, $class;
- $self->init;
$self
}
-sub init {
+sub get_old_form {
+ my ($self, $node) = @_;
+
+ my $form = {};
+
+ for ($node->nodes) {
+ if ($_->eq_ns ('register')) {
+ $form->{$_->name} = $_->text;
+ }
+ }
+
+ $form
+}
+
+sub try_fillout_registration {
+ my ($self, $username, $password) = @_;
+
+ my $form;
+ my $nform;
+ if (my $df = $self->get_data_form) {
+ my $af = Net::XMPP2::Ext::DataForm->new;
+ $af->make_answer_form ($df);
+ $af->set_field_value (username => $username);
+ $af->set_field_value (password => $password);
+ $nform = $af;
+
+ } else {
+ my $frm = $self->get_standard_form_fields;
+ $form = {
+ username => $username,
+ password => $password
+ };
+ }
+
+ return
+ Net::XMPP2::Ext::RegisterForm->new (
+ type => $self->{type},
+ form => $nform,
+ old_form => $form,
+ answered => 1
+ );
+}
+
+sub type {
+ my ($self) = @_;
+ $self->{type}
+}
+
+sub is_answer_form {
+ my ($self) = @_;
+ $self->{answered}
+}
+
+sub is_already_registered {
my ($self) = @_;
- my $node = $self->{node};
+ exists $self->{old_form}->{registered}
+}
+
+sub init_new_form {
+ my ($self, $node) = @_;
+
+ my (@x) = $node->find_all ([qw/data_form x/]);
+
+ if (@x) {
+ my $df = Net::XMPP2::Ext::DataForm->new;
+ $df->from_node (@x);
+ $self->{form} = $df;
+
+ } else {
+ die "TODO!";
+ }
+}
+
+sub get_standard_form_fields {
+ my ($self) = @_;
+ $self->{old_form};
+}
+
+sub get_data_form {
+ my ($self) = @_;
+ if ($self->{type} eq 'form') {
+ return $self->{form};
+ }
+}
- # TODO
+sub init_from_node {
+ my ($self, $node) = @_;
+
+ if ($node->find_all ([qw/data_form x/])) {
+ $self->init_new_form ($node);
+ $self->{type} = 'form';
+ } else {
+ $self->{type} = 'standard';
+ }
+ my $form = $self->get_old_form ($node);
+ $self->{old_form} = $form;
}
=head1 AUTHOR
@@ -83,7 +83,7 @@ sub init {
my ($self) = @_;
}
-=item B<send_registration_request ($cb)>
+=item B<send_registration_request ($con, $cb)>
This method sends a register form request.
C<$cb> will be called when either the form arrived or
@@ -99,12 +99,26 @@ object.
=cut
sub send_registration_request {
- my ($self, $cb) = @_;
+ my ($self, $con, $cb) = @_;
+ $con->send_iq (get => {
+ defns => 'register',
+ node => { ns => 'register', name => 'query' }
+ }, sub {
+ my ($node, $error) = @_;
+ my $form;
+ if ($node) {
+ $form = Net::XMPP2::Ext::RegisterForm->new;
+ $form->init_from_node ($node);
+ }
+ $cb->($self, $con, $form, $error);
+ });
}
+=item B<submit_form ($con, $form, $cb)>
+
=back
=head1 AUTHOR
@@ -37,13 +37,14 @@ sub remove_connection {
}
sub spawn_connection {
- my ($self) = @_;
+ my ($self, %args) = @_;
$self->{con} = Net::XMPP2::IM::Connection->new (
jid => $self->jid,
password => $self->{password},
($self->{host} ? (override_host => $self->{host}) : ()),
($self->{port} ? (override_port => $self->{port}) : ()),
+ %args
)
}
@@ -49,14 +49,30 @@ even presences will be stored in there, except that the C<get_contacts>
method on the roster object won't return anything as there are
no roster items.
+=item initial_presence => $priority
+
+This sets whether the initial presence should be sent. C<$priority>
+should be the priority of the initial presence. The default value
+for the initial presence C<$priority> is 10.
+
+If you pass a undefined value as C<$priority> no initial presence will
+be sent!
+
=back
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
- my $self = $class->SUPER::new (@_);
+
+ my %args = @_;
+
+ unless (exists $args{initial_presence}) {
+ $args{initial_presence} = 10;
+ }
+
+ my $self = $class->SUPER::new (%args);
$self->{roster} = Net::XMPP2::IM::Roster->new (connection => $self);
@@ -114,13 +130,26 @@ sub send_session_iq {
sub init_connection {
my ($self) = @_;
- $self->{session_active} = 1;
if ($self->{dont_retrieve_roster}) {
- $self->send_presence;
+ $self->initial_presence;
+ $self->{session_active} = 1;
+ $self->event ('session_ready');
+
} else {
- $self->retrieve_roster (sub { $self->send_presence });
+ $self->retrieve_roster (sub {
+ $self->initial_presence;
+ $self->{session_active} = 1;
+ $self->event ('session_ready');
+ });
+ }
+}
+
+sub initial_presence {
+ my ($self) = @_;
+ if (defined $self->{initial_presence}) {
+ $self->send_presence (undef, undef, priority => $self->{initial_presence});
}
- $self->event ('session_ready');
+ # else do nothing
}
=item B<retrieve_roster ($cb)>
@@ -14,12 +14,13 @@ our %NAMESPACES = (
bind => 'urn:ietf:params:xml:ns:xmpp-bind',
tls => 'urn:ietf:params:xml:ns:xmpp-tls',
roster => 'jabber:iq:roster',
+ register => 'jabber:iq:register',
version => 'jabber:iq:version',
session => 'urn:ietf:params:xml:ns:xmpp-session',
xml => 'http://www.w3.org/XML/1998/namespace',
disco_info => 'http://jabber.org/protocol/disco#info',
disco_items => 'http://jabber.org/protocol/disco#items',
- register => 'http://jabber.org/features/iq-register',
+ register_f => 'http://jabber.org/features/iq-register',
iqauth => 'http://jabber.org/features/iq-auth',
data_form => 'jabber:x:data',
muc => 'http://jabber.org/protocol/muc',
View
@@ -11,13 +11,16 @@ my @req;
sub schedule {
my $reqcnt = scalar (keys %reqh);
if ($reqcnt == 0 && !@req) {
- print "no more jobs, finishing...\n";
+ warn "no more jobs, finishing...\n";
$J->broadcast;
}
- while ($reqcnt < 20) {
+ while ($reqcnt < 200) {
my $r = pop @req;
return unless defined $r;
- $r->[0]->(addreq ($r->[1]));
+ eval {
+ $r->[0]->(addreq ($r->[1]));
+ };
+ if ($@) { warn "EXCEPTION: $@\n" }
$reqcnt = scalar (keys %reqh);
}
}
@@ -33,11 +36,12 @@ sub push_request {
our $t;
sub timer {
- $t = AnyEvent->timer (after => 2, cb => sub {
+ $t = AnyEvent->timer (after => 1, cb => sub {
schedule;
my $reqcnt = scalar (keys %reqh);
$reqcnt += @req;
- print "$reqcnt outstanding requests\n";
+ my $rreqcnt = scalar (keys %reqh);
+ warn "$reqcnt outstanding requests [$rreqcnt in progress]\n";
timer ();
});
}
View
@@ -13,18 +13,6 @@ our $J = AnyEvent->condvar;
our $datafile = "conferences.stor";
our $data = {};
-sub load_servers {
- my $parser = XML::DOM::Parser->new;
- my $doc = $parser->parsefile ("servers.xml");
-
- my %servers;
- for ($doc->findnodes ('/query/item')) {
- my $n = $_->getAttributeNode ('jid');
- $servers{$n->getValue} = 1;
- }
- keys %servers
-}
-
# locking mechanism for requests
our %req;
our $id = 0;
@@ -50,7 +38,7 @@ print "finished data: " . join (',', keys %$data) . "\n";
sub sync_data { store $data, $datafile }
# MAIN START
-my @servers = load_servers ();
+my @servers = map { s/^\s*(\S+)\s*$/\1/; $_ } <STDIN>;
my $cl = Net::XMPP2::Client->new ();
my $d = Net::XMPP2::Ext::Disco->new;
$cl->add_extension ($d);
@@ -105,7 +93,7 @@ $cl->reg_cb (
my $c = $acc->connection ();
$c->set_default_iq_timeout (30);
- my $timer_step = 3;
+ my $timer_step = 0.1;
my $timer_cnt = 0;
for my $SERVER (@servers) {
@@ -117,11 +105,14 @@ $cl->reg_cb (
cb => sub {
disco_items ($c, $SERVER, sub {
my ($i) = @_;
- for ($i->items) {
- disco_info ($c, $_->{jid}, sub {
+ print "got items for $SERVER\n";
+ for my $it ($i->items) {
+ disco_info ($c, $it->{jid}, sub {
my ($i) = @_;
- if (grep { $_->{category} eq 'conference' && $_->{type} eq 'text' } $i->identities ()) {
- $data->{$SERVER} = $i->jid;
+ my @f = grep { $_ =~ /^muc/ } keys %{$i->features || {}};
+ my @c = grep { $_->{category} eq 'conference' && $_->{type} eq 'text' } $i->identities ();
+ if (@c && !@f) {
+ $data->{$SERVER}->{$i->jid} = 1;
print "\t*** found conference " . $i->jid . "\n";
sync_data ();
}
Oops, something went wrong.

0 comments on commit 22cf02c

Please sign in to comment.