[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 = {};

# 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 = map { s/^\s*(\S+)\s*$/\1/; $_ } <STDIN>;
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";
   },
   iq_result_cb_exception => sub {
      my ($cl, $acc, $ex) = @_;
      print "EXCEPTION: $ex\n";
   },
   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 = 0.1;
      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) = @_;
                  print "got items for $SERVER\n";
                  for my $it ($i->items) {
                     disco_info ($c, $it->{jid}, sub {
                        my ($i) = @_;
                        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 ();
                        }
                     });
                  }
               });
               delete $req_timers{$t};
               finreq ($ID);
            }
         );

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

$cl->start;

$J->wait
Revision:	1.4
Committed:	Tue Jul 24 12:31:15 2007 UTC (16 years, 11 months ago) by elmex
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.3:	+1 -4 lines
Log Message:	documentation update
#	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	# locking mechanism for requests
17			our %req;
18			our $id = 0;
19			sub addreq { my $k = $id . "_" . $_[0]; $req{$k} = 1; $id++; $k }
20			sub finreq { delete $req{$_[0]}; my @k = keys %req; $J->broadcast if @k == 0 }
21
22			# timer for status output
23			our $t;
24			sub mktimer {
25			$t = AnyEvent->timer (after => 1, cb => sub {
26			my @keys = keys %req;
27			my @ok = grep { $_ !~ /_timer_/ } @keys;
28			my $timers = scalar (grep { $_ =~ /_timer_/ } @keys);
29			print "\t*** pending requests $timers timers, and : " . join (',', @ok) . "\n";
30			mktimer ();
31			});
32			}
33			mktimer;
34
35			# server data cache
36			eval { $data = retrieve $datafile };
37			print "finished data: " . join (',', keys %$data) . "\n";
38			sub sync_data { store $data, $datafile }
39	elmex	1.1
40			# MAIN START
41	elmex	1.3	my @servers = map { s/^\s(\S+)\s$/\1/; $_ } <STDIN>;
42	elmex	1.1	my $cl = Net::XMPP2::Client->new ();
43			my $d = Net::XMPP2::Ext::Disco->new;
44			$cl->add_extension ($d);
45			$cl->add_account ('net_xmpp2@jabber.org/test', 'test');
46
47			sub disco_info {
48			my ($con, $jid, $cb) = @_;
49
50			my $ID = addreq ("di_$jid");
51			$d->request_info ($con, $jid, undef, sub {
52			my ($d, $i, $e) = @_;
53			if ($e) {
54			print "error on disco info on $jid: " . $e->string . "\n";
55			} else {
56			$cb->($i);
57			}
58			finreq ($ID)
59			});
60			}
61
62			sub disco_items {
63			my ($con, $jid, $cb) = @_;
64
65			my $ID = addreq ("dit_$jid");
66			$d->request_items ($con, $jid, undef, sub {
67			my ($d, $i, $e) = @_;
68			if ($e) {
69			print "error on disco items on $jid: " . $e->string . "\n";
70			} else {
71			$cb->($i);
72			}
73			finreq ($ID)
74			});
75			}
76
77			my %req_timers;
78
79			$cl->reg_cb (
80			error => sub {
81			my ($cl, $acc, $err) = @_;
82			print "ERROR: " . $err->string . "\n";
83			},
84			iq_result_cb_exception => sub {
85			my ($cl, $acc, $ex) = @_;
86			print "EXCEPTION: $ex\n";
87			},
88			session_ready => sub {
89			my ($cl, $acc) = @_;
90			print "session ready, requesting items for $ARGV[0]\n";
91			my $c = $acc->connection ();
92			$c->set_default_iq_timeout (30);
93
94	elmex	1.3	my $timer_step = 0.1;
95	elmex	1.1	my $timer_cnt = 0;
96
97			for my $SERVER (@servers) {
98			next if $data->{$SERVER};
99			my $t = $timer_cnt;
100
101			my $ID = addreq ("timer_$t");
102			$req_timers{$t} = AnyEvent->timer (after => $t,
103			cb => sub {
104			disco_items ($c, $SERVER, sub {
105			my ($i) = @_;
106	elmex	1.3	print "got items for $SERVER\n";
107			for my $it ($i->items) {
108			disco_info ($c, $it->{jid}, sub {
109	elmex	1.1	my ($i) = @_;
110	elmex	1.3	my @f = grep { $_ =~ /^muc/ } keys %{$i->features \|\| {}};
111			my @c = grep { $_->{category} eq 'conference' && $_->{type} eq 'text' } $i->identities ();
112			if (@c && !@f) {
113			$data->{$SERVER}->{$i->jid} = 1;
114	elmex	1.1	print "\t*** found conference " . $i->jid . "\n";
115			sync_data ();
116			}
117			});
118			}
119			});
120			delete $req_timers{$t};
121			finreq ($ID);
122			}
123			);
124
125			$timer_cnt += $timer_step;
126			}
127	elmex	1.4	$cl->unreg_me;
128	elmex	1.1	},
129			message => sub {
130			my ($cl, $acc, $msg) = @_;
131			print "message from: " . $msg->from . ": " . $msg->any_body . "\n";
132			}
133			);
134
135			$cl->start;
136
137			$J->wait