[ViewVC] Annotation of: cvs/cvsroot/Net-XMPP2/samples/conference_lister

#!/opt/perl/bin/perl
use strict;
use utf8;
use Event;
use AnyEvent;
use Net::XMPP2::Client;
use Net::XMPP2::Ext::Disco;
use Net::XMPP2::Ext::DataForm;
use Storable;
use XML::DOM::XPath;

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;
sub addreq { my $k = $id . "_" . $_[0]; $req{$k} = 1; $id++; $k }
sub finreq { delete $req{$_[0]}; my @k = keys %req; $J->broadcast if @k == 0 }

# timer for status output
our $t;
sub mktimer {
   $t = AnyEvent->timer (after => 1, cb => sub {
      my @keys = keys %req;
      my @ok = grep { $_ !~ /_timer_/ } @keys;
      my $timers = scalar (grep { $_ =~ /_timer_/ } @keys);
      print "\t*** pending requests $timers timers, and : " . join (',', @ok) . "\n";
      mktimer ();
   });
}
mktimer;

# server data cache
eval { $data = retrieve $datafile };
print "finished data: " . join (',', keys %$data) . "\n";
sub sync_data { store $data, $datafile }

# MAIN START
my @servers = load_servers ();
my $cl = Net::XMPP2::Client->new ();
my $d  = Net::XMPP2::Ext::Disco->new;
$cl->add_extension ($d);
$cl->add_account ('net_xmpp2@jabber.org/test', 'test');

sub disco_info {
   my ($con, $jid, $cb) = @_;

   my $ID = addreq ("di_$jid");
   $d->request_info ($con, $jid, undef, sub {
      my ($d, $i, $e) = @_;
      if ($e) {
         print "error on disco info on $jid: " . $e->string . "\n";
      } else {
         $cb->($i);
      }
      finreq ($ID)
   });
}

sub disco_items {
   my ($con, $jid, $cb) = @_;

   my $ID = addreq ("dit_$jid");
   $d->request_items ($con, $jid, undef, sub {
      my ($d, $i, $e) = @_;
      if ($e) {
         print "error on disco items on $jid: " . $e->string . "\n";
      } else {
         $cb->($i);
      }
      finreq ($ID)
   });
}

my %req_timers;

$cl->reg_cb (
   error => sub {
      my ($cl, $acc, $err) = @_;
      print "ERROR: " . $err->string . "\n";
      1
   },
   iq_result_cb_exception => sub {
      my ($cl, $acc, $ex) = @_;
      print "EXCEPTION: $ex\n";
      1
   },
   session_ready => sub {
      my ($cl, $acc) = @_;
      print "session ready, requesting items for $ARGV[0]\n";
      my $c = $acc->connection ();
      $c->set_default_iq_timeout (30);

      my $timer_step = 3;
      my $timer_cnt = 0;

      for my $SERVER (@servers) {
         next if $data->{$SERVER};
         my $t = $timer_cnt;

         my $ID = addreq ("timer_$t");
         $req_timers{$t} = AnyEvent->timer (after => $t,
            cb => sub {
               disco_items ($c, $SERVER, sub {
                  my ($i) = @_;
                  for ($i->items) {
                     disco_info ($c, $_->{jid}, sub {
                        my ($i) = @_;
                        if (grep { $_->{category} eq 'conference' && $_->{type} eq 'text' } $i->identities ()) {
                           $data->{$SERVER} = $i->jid;
                           print "\t*** found conference " . $i->jid . "\n";
                           sync_data ();
                        }
                     });
                  }
               });
               delete $req_timers{$t};
               finreq ($ID);
            }
         );

         $timer_cnt += $timer_step;
      }
      0
   },
   message => sub {
      my ($cl, $acc, $msg) = @_;
      print "message from: " . $msg->from . ": " . $msg->any_body . "\n";
      1
   }
);

$cl->start;

$J->wait
Revision:	1.2
Committed:	Mon Jul 9 20:24:45 2007 UTC (17 years ago) by elmex
Branch:	MAIN
Changes since 1.1:	+35 -1 lines
Log Message:	some changes...
#	User	Rev	Content
1	elmex	1.1	#!/opt/perl/bin/perl
2			use strict;
3			use utf8;
4			use Event;
5			use AnyEvent;
6			use Net::XMPP2::Client;
7			use Net::XMPP2::Ext::Disco;
8			use Net::XMPP2::Ext::DataForm;
9			use Storable;
10			use XML::DOM::XPath;
11
12			our $J = AnyEvent->condvar;
13			our $datafile = "conferences.stor";
14			our $data = {};
15
16	elmex	1.2	sub load_servers {
17			my $parser = XML::DOM::Parser->new;
18			my $doc = $parser->parsefile ("servers.xml");
19
20			my %servers;
21			for ($doc->findnodes ('/query/item')) {
22			my $n = $_->getAttributeNode ('jid');
23			$servers{$n->getValue} = 1;
24			}
25			keys %servers
26			}
27
28			# locking mechanism for requests
29			our %req;
30			our $id = 0;
31			sub addreq { my $k = $id . "_" . $_[0]; $req{$k} = 1; $id++; $k }
32			sub finreq { delete $req{$_[0]}; my @k = keys %req; $J->broadcast if @k == 0 }
33
34			# timer for status output
35			our $t;
36			sub mktimer {
37			$t = AnyEvent->timer (after => 1, cb => sub {
38			my @keys = keys %req;
39			my @ok = grep { $_ !~ /_timer_/ } @keys;
40			my $timers = scalar (grep { $_ =~ /_timer_/ } @keys);
41			print "\t*** pending requests $timers timers, and : " . join (',', @ok) . "\n";
42			mktimer ();
43			});
44			}
45			mktimer;
46
47			# server data cache
48			eval { $data = retrieve $datafile };
49			print "finished data: " . join (',', keys %$data) . "\n";
50			sub sync_data { store $data, $datafile }
51	elmex	1.1
52			# MAIN START
53			my @servers = load_servers ();
54			my $cl = Net::XMPP2::Client->new ();
55			my $d = Net::XMPP2::Ext::Disco->new;
56			$cl->add_extension ($d);
57			$cl->add_account ('net_xmpp2@jabber.org/test', 'test');
58
59			sub disco_info {
60			my ($con, $jid, $cb) = @_;
61
62			my $ID = addreq ("di_$jid");
63			$d->request_info ($con, $jid, undef, sub {
64			my ($d, $i, $e) = @_;
65			if ($e) {
66			print "error on disco info on $jid: " . $e->string . "\n";
67			} else {
68			$cb->($i);
69			}
70			finreq ($ID)
71			});
72			}
73
74			sub disco_items {
75			my ($con, $jid, $cb) = @_;
76
77			my $ID = addreq ("dit_$jid");
78			$d->request_items ($con, $jid, undef, sub {
79			my ($d, $i, $e) = @_;
80			if ($e) {
81			print "error on disco items on $jid: " . $e->string . "\n";
82			} else {
83			$cb->($i);
84			}
85			finreq ($ID)
86			});
87			}
88
89			my %req_timers;
90
91			$cl->reg_cb (
92			error => sub {
93			my ($cl, $acc, $err) = @_;
94			print "ERROR: " . $err->string . "\n";
95			1
96			},
97			iq_result_cb_exception => sub {
98			my ($cl, $acc, $ex) = @_;
99			print "EXCEPTION: $ex\n";
100			1
101			},
102			session_ready => sub {
103			my ($cl, $acc) = @_;
104			print "session ready, requesting items for $ARGV[0]\n";
105			my $c = $acc->connection ();
106			$c->set_default_iq_timeout (30);
107
108			my $timer_step = 3;
109			my $timer_cnt = 0;
110
111			for my $SERVER (@servers) {
112			next if $data->{$SERVER};
113			my $t = $timer_cnt;
114
115			my $ID = addreq ("timer_$t");
116			$req_timers{$t} = AnyEvent->timer (after => $t,
117			cb => sub {
118			disco_items ($c, $SERVER, sub {
119			my ($i) = @_;
120			for ($i->items) {
121			disco_info ($c, $_->{jid}, sub {
122			my ($i) = @_;
123			if (grep { $_->{category} eq 'conference' && $_->{type} eq 'text' } $i->identities ()) {
124			$data->{$SERVER} = $i->jid;
125			print "\t*** found conference " . $i->jid . "\n";
126			sync_data ();
127			}
128			});
129			}
130			});
131			delete $req_timers{$t};
132			finreq ($ID);
133			}
134			);
135
136			$timer_cnt += $timer_step;
137			}
138			0
139			},
140			message => sub {
141			my ($cl, $acc, $msg) = @_;
142			print "message from: " . $msg->from . ": " . $msg->any_body . "\n";
143			1
144			}
145			);
146
147			$cl->start;
148
149			$J->wait