The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/opt/perl/bin/perl
use strict;
use utf8;
use AnyEvent;
use AnyEvent::XMPP::Client;
use AnyEvent::XMPP::Ext::Version;
use POSIX qw/strftime/;

my ($jid,$pass) = qw/net_xmpp2@jabber.org test/;
($jid, $pass) = @ARGV if @ARGV;

sub timestamp {
   strftime "%d%m%Y_%H%M", localtime (time);
}
my $TIMESTAMP = timestamp ();

sub append_outputfile {
   open OUT, ">>disco_version.\Q$TIMESTAMP\E.output"
      or die "Couldn't open disco_version.output: $!\n";
   print OUT $_[0];
   close OUT;
}
sub append_failed {
   open OUT, ">>disco_version.\Q$TIMESTAMP\E.failed"
      or die "Couldn't open disco_version.output: $!\n";
   print OUT $_[0];
   close OUT;
}

my %req;
my ($out_cnt, $in_cnt);

sub version_req {
   my ($vers, $con, $dest) = @_;
   return if $req{$dest};
   $out_cnt++;

   $vers->request_version ($con, $dest, sub {
      my ($version, $error) = @_;
      $in_cnt++;

      if ($error) {
         warn "$dest: DISCO VERSION ERROR $dest: " . $error->string . "\n";
         append_failed ("$dest\t".$error->string."\n");
      } else {
         my $from = $version->{jid};
         my $name = $version->{name};
         my $ver  = $version->{version};
         my $os   = $version->{os};
         $ver  =~ s/[\n\t]//g;
         $name =~ s/[\n\t]//g;
         $os   =~ s/[\n\t]//g;
         print "$dest: $from: name: $name version: $ver os: $os\n";
         append_outputfile ("$from\t$name\t$ver\t$os\n");
      }
   });
}

my $j = AnyEvent->condvar;
my $cl = AnyEvent::XMPP::Client->new;# (debug => 1);
my $vers = AnyEvent::XMPP::Ext::Version->new;
$cl->add_extension ($vers);
my $t = undef;
my @jids = map { chomp; $_ } <STDIN>;
sub mkti {
   my ($con) = @_;
   $t = AnyEvent->timer (after => 1, cb => sub {
      for (1..50) {
         my $j = pop @jids;
         if ($j) {
            version_req ($vers, $con, $j);
         } else {
            print "no more jids to query ($out_cnt/$in_cnt)...\n";
            last;
         }
      }
      mkti ($con);
   });
}
$cl->add_account ($jid, $pass);#, undef, undef, { disable_ssl => 1 });
$cl->reg_cb (
   session_ready => sub {
      my ($cl, $acc) = @_;
      $acc->connection->set_default_iq_timeout (300);
      warn "session ready!\n";
      mkti ($acc->connection);
      $cl->unreg_me
   },
   disconnect => sub {
      my ($cl, $acc, $h, $p, $reas) = @_;
      print "disconnect ($h:$p): $reas\n";
   },
   error => sub {
      my ($cl, $acc, $err) = @_;
      print "ERROR: " . $err->string . "\n";
   },
   message => sub {
      my ($cl, $acc, $msg) = @_;
      print "message from: " . $msg->from . ": " . $msg->any_body . "\n";
   }
);
$cl->start;
$j->wait;