<commit_before>package JEvent;

use 5.006;
use strict;
use warnings;

require Exporter;
use AutoLoader qw(AUTOLOAD);

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use JEvent ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	
);
our $VERSION = '0.12';

use Net::XMPP qw(Client);
use Net::XMPP::JID;
use Data::UUID;
use Net::SPOCP;
use Sys::Syslog qw(:DEFAULT);
use Config::IniFiles;

sub new
  {
    my $self = shift;
    my $class = ref $self || $self;

    my %me = @_;
    $me{Config} = Config::IniFiles->new() unless UNIVERSAL::isa($me{Config},'Config::IniFiles');

    my $this = bless \%me,$class;
    $this->init();
  }

sub LogWarn
  {
    my($self,$msg,@args) = @_;

    syslog('warning',$msg,@args);
  }

sub LogError
  {
    my($self,$msg,@args) = @_;

    syslog('error',$msg,@args);
  }

sub LogInfo
  {
    my($self,$msg,@args) = @_;

    syslog('info',$msg,@args);
  }

sub LogDebug
  {
    my($self,$msg,@args) = @_;

    syslog('debug',$msg,@args);
  }

sub Client
  {
    $_[0]->{_xmpp};
  }

sub JID
  {
    $_[0]->{_jid}
  }

sub Hostname
  {
    $_[0]->JID->GetServer();
  }

sub Username
  {
    $_[0]->JID->GetUserID();
  }

sub Resource
  {
    $_[0]->JID->GetResource();
  }

sub Password
  {
    my $pw = $_[0]->{Password};
    return $pw if $pw;
    &{$_[0]->{PasswordCB}}($_[0]) if ref $_[0]->{PasswordCB};
    die "Missing Password and/or PasswordCB\n";
  }

sub cfg
  {
    my $self = shift;
    $self->{Config}->val(@_);
  }

sub gen_uuid
  {
    $_[0]->{_ug}->create_str();
  }

sub init
  {
    my $self = shift;

    openlog "JEvent $0","pid",'LOG_USER';

    $self->{_jid} = Net::XMPP::JID->new($self->{JID} || $self->cfg('JEvent','JID'));
    $self->{Timeout} = $self->cfg('JEvent','Timeout') unless $self->{Timeout};
    $self->{Timeout} = 5 unless $self->{Timeout};
    $self->{Password} = $self->cfg('JEvent','Password') unless $self->{Password};
    $self->{_ug} = Data::UUID->new();

    my @opts = ();
    $self->{DebugLevel} = $self->cfg('JEvent','DebugLevel') unless $self->{DebugLevel};
    $self->{DebugFile} = $self->cfg('JEvent','DebugFile') unless $self->{DebugFile};
    push(@opts,debuglevel=>$self->{DebugLevel}) if $self->{DebugLevel};
    push(@opts,debugfile=>$self->{DebugFile}) if $self->{DebugFile};

    $self->{Host} = $self->cfg('PubSub','Host') unless $self->{Host};
    $self->{Node} = $self->cfg('PubSub','Node') unless $self->{Node};
    $self->{Description} = $self->cfg('JEvent','Description') unless $self->{Description};

    $self->{SPOCPServer} = $self->cfg('SPOCP','Server') unless $self->{SPOCPServer};
    $self->{UseTLS} = $self->cfg('JEvent','UseTLS') unless $self->{UseTLS};
    $self->{SSLVerify} = $self->cfg('SSL','verify') unless $self->{SSLVerify};
    $self->{CAFile} = $self->cfg('SSL','cafile') unless $self->{CAFile};
    $self->{CADir} = $self->cfg('SSL','cadir') unless $self->{CADir};
    $self->{ProcessTimeout} = $self->cfg('JEvent','ProcessTimeout');

    $self->{_xmpp} = Net::XMPP::Client->new(@opts);
    $self->Client->SetCallBacks(onauth=>sub
				 {
				   $self->Client->PresenceSend();
				   &{$self->{StartCB}}($self) if ref $self->{StartCB} eq 'CODE';
				 },
				 onprocess=>sub
				 {
				   &{$self->{ProcessCB}}($self) if ref $self->{ProcessCB} eq 'CODE';
				 });

    $self->Client->SetMessageCallBacks(error=>sub
					{
					  #warn $_[1]->GetXML();
					},
					groupchat=>sub
					{
					  &{$self->{MessageCB}}($self,@_) if ref $self->{MessageCB} eq 'CODE';
					},
					normal=>sub
					{
					  &{$self->{MessageCB}}($self,@_) if ref $self->{MessageCB} eq 'CODE';
					},
					chat=>sub
					{
					  &{$self->{MessageCB}}($self,@_) if ref $self->{MessageCB} eq 'CODE';
					});

    $self->Client->SetPresenceCallBacks(subscribe => sub {
					   my $ok = ref $self->{SubscriptionAuthorization} eq 'CODE' ?
					     &{$self->{SubscriptionAuthorization}}($self,@_) : 1;
                                           warn $_[1]->GetXML();
					   if ($ok)
					     {
					       $self->Client->PresenceSend(to=>$_[1]->GetFrom(),type=>'subscribed');
					     }
					   else
					     {
					       $self->Client->PresenceSend(to=>$_[1]->GetFrom(),type=>'unsubscribed');
					     }
					 });

    $self->Client->SetXPathCallBacks("/message/event[\@xmlns=\'http://jabber.org/protocol/pubsub#event\']" => sub
				      {
					&{$self->{EventCB}}($self,@_) if ref $self->{EventCB} eq 'CODE';
				      });

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/pubsub',
				 tag=>'pubsub',
				 xpath=>{
					 Publish => { calls => [qw/Get Add Defined/],
						      type => 'child',
						      path => 'publish',
						      child => { ns => '__netxmpp__:pubsub:publish' } },

					 Retract => { calls => [qw/Get Add Defined/],
						      type => 'child',
						      path => 'retract',
						      child => { ns => '__netxmpp__:pubsub:retract' } },

					 Subscribe => { calls => [qw/Get Add Defined/],
							type => 'child',
							path => 'subscribe',
							child => { ns => '__netxmpp__:pubsub:subscribe' } },

					 Unsubscribe => { calls => [qw/Get Add Defined/],
							  type => 'child',
							  path => 'unsubscribe',
							  child => { ns => '__netxmpp__:pubsub:unsubscribe' } },

					 Entity => { calls => [qw/Get Add Defined/],
						     type => 'child',
						     path => 'entity',
						     child => { ns => '__netxmpp__:pubsub:entity' } },

					 Affiliations => { calls => [qw/Get Add Defined/],
							   type => 'child',
							   path => 'affiliations',
							   child => { ns => '__netxmpp__:pubsub:affiliations' } },

					 Create => { calls => [qw/Get Add Defined/],
					             type => 'child',
					             path => 'create',
						     child => { ns => '__netxmpp__:pubsub:create' } },
					
					 Delete => { calls => [qw/Get Add Defined/],
                                                     type => 'child',
                                                     path => 'delete',
                                                     child => { ns => '__netxmpp__:pubsub:delete' } },

                                         Purge => { calls => [qw/Get Add Defined/],
                                                     type => 'child',
                                                     path => 'purge',
                                                     child => { ns => '__netxmpp__:pubsub:purge' } },

                                         Entities => { calls => [qw/Get Add Defined/],
                                                     type => 'child',
                                                     path => 'entities',
                                                     child => { ns => '__netxmpp__:pubsub:entities' } },

					 Items => { calls => [qw/Get Set/],
						    type => 'child',
						    path => 'items',
						    child => { ns => '__netxmpp__:pubsub:items' } },
					},
				);

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:publish',
				 tag => 'publish',
				 xpath=>{
					 Node => { path => '@node' },
					 Item => { calls => [qw/Get Set Add/],
						   type => 'child',
						   path => 'item',
						   child => { ns => '__netxmpp__:pubsub:publish:item' } }

					},
				);

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:create',
                                tag => 'create',
                                xpath => {
                                          Node => { path => '@node' }
                                         }
                                );

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:delete',
                                tag => 'delete',
                                xpath => {
                                          Node => { path => '@node' }
                                         }
                                );

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:purge',
                                tag => 'purge',
                                xpath => {
                                          Node => { path => '@node' }
                                         }
                                );

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:entities',
                                tag => 'entities',
                                xpath => {
                                          Node => { path => '@node' },
					  Entity => { calls => [qw/Get Set Add/],
					              type => 'child',
						      path => 'entity',
						      child => { ns => '__netxmpp__:pubsub:entity' } }
                                         }
                                );

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:retract',
				 tag => 'retract',
				 xpath=>{
					 Node => { path => '@node' },
					 Item => { calls => [qw/Get Set/],
						   type => 'child',
						   path => 'item',
						   child => { ns => '__netxmpp__:pubsub:retract:item' } }

					},
				);

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:publish:item',
				 tag => 'item',
				 xpath=>{
					 Id => { path => '@id' },
					 Content => { type => 'raw', path => '.' }
					});

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:retract:item',
				 tag => 'item',
				 xpath=>{
					 Id => { path => '@id' },
					});

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:subscribe',
				 tag => 'subscribe',
				 xpath=>{
					 Node => { path => '@node' },
					 SubID => { path => '@subid' },
					 JID => { type => 'jid', path => '@jid' }
					});

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:unsubscribe',
				 tag => 'unsubscribe',
				 xpath=>{
					 Node => { path => '@node' },
					 JID => { type => 'jid', path => '@jid' },
					 SubID => { path => '@subid' }
					});

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:entity',
				 tag => 'entity',
				 xpath=>{
					 Node => { path => '@node' },
					 JID => { type => 'jid', path => '@jid' },
					 Affiliation => { path => '@affiliation' },
					 SubID => { path => '@subid' },
					 Subscription => { path => '@subscription' },
                                         Subscribed => { path => '@subscribed' }
					});

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:affiliations',
				 tag => 'affiliations',
				 xpath => {
					   Entity => { calls => [qw/Get Add Defined/],
						       type => 'child',
						       path => 'entity',
						       child => { ns => '__netxmpp__:pubsub:entity' } }
					  });

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:items',
				 tag => 'items',
				 xpath=>{
					 Node => { path => '@node' },
					 JID => { type => 'jid' },
					 SubID => { path => '@subid' },
					 MaxItems => { path => '@max_items' },
					 Item => { calls => [ qw/Add/],
						   type => 'child',
						   path => 'item',
						   child => { ns => '__netxmpp__:pubsub:item' } },
					 Items => { calls => [ qw/Get/],
						    type => 'child',
						    path => 'item',
						    child => { ns => '__netxmpp__:pubsub:item' } }
					});

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/pubsub#owner',
				tag => 'pubsub',
				xpath => {
					  Configure => { calls => [ qw/Get Add/],
							 type => 'child',
							 path => 'configure',
							 child => { ns => '__netxmpp__:pubsub:owner:configure' } }
					 });

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:owner:configure',
				tag => 'configure',
				xpath => {
					  Node => { path => '@node' },
					  Form => { calls => [ qw /Get Add Defined/ ],
						    type => 'child',
						    path => 'x',
						    child => { ns => 'jabber:x:data' } }
					 });

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/pubsub#event',
				tag => 'event',
				xpath => {
					  Items => { calls => [ qw/Get Add/],
						     type => 'child',
						     path => 'items',
						     child => { ns => '__netxmpp__:pubsub:items' } },
					  Delete => { calls => [ qw/Get Add/],
						      type => 'child',
						      path => 'delete',
						      child => { ns => '__netxmpp__:pubsub:delete' } },
					  Purge => { calls => [ qw/Get Add/],
						     type => 'child',
						     path => 'purge',
						     child => { ns => '__netxmpp__:pubsub:purge' } }
					 });

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/muc',
				 tag => 'x',
				 xpath => {
					   Password => { path => '@password' },
					   Form => { calls => [ qw/Set Defined Get/ ],
						     type => 'child',
						     path => 'x',
						     child => { ns => 'jabber:x:data' } }
					  });

    $self->Client->AddNamespace(ns=>'jabber:x:conference',
				 tag => 'x',
				 xpath => {
					   JID => { path => '@jid', type => 'jid' }
					  });

    $self->Client->AddNamespace(ns=>'http://jevent.it.su.se/NS/command',
				tag => 'command',
				xpath => {
					  Form => { calls => [ qw/Set Defined Get/ ],
						    type  => 'child',
						    path  => 'x',
						    child => { ns => 'jabber:x:data' } }
					 });

    $self->Client->AddNamespace(ns=>'jabber:x:data',
                                tag=>'x',
                                xpath => {
                                           Type => { path => '@type' },
                                           Title => { path => 'title/text()' },
                                           Instructions => { path => 'instructions/text()' },
                                           Field => { calls => [ qw/Get Add/ ],
                                                      type => 'child',
                                                      path => 'field',
                                                      child => { ns => '__netxmpp__:form:field' } }
                                         });

    $self->Client->AddNamespace(ns=>'__netxmpp__:form:field',
                                tag=>'field',
                                xpath => {
					  Type => { path => '@type' },
					  Label => { path => '@label' },
					  Var => { path => '@var' },
					  Value => { path => 'value' },
					  Option => { calls => [ qw /Get Add/ ],
						      type => 'child',
						      path => 'option',
						      child => { ns => '__netxmpp__:form:field:option' }}
                                         });

    $self->Client->AddNamespace(ns=>'__netxmpp__:form:field:option',
				tag=>'option',
				xpath => {
					  Value => { path => 'value' },
					  Label => { path => '@label' }
					 });

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/disco#items',
				tag=>'query',
				xpath => {
					  Item => {
						   calls => [ qw/Get Add/ ],
						   type => 'child',
						   path => 'item',
						   child => { ns => '__netxmpp__:disco:items' }
						  },
					  Node => { path => '@node' }
					 });

    $self->Client->AddNamespace(ns=>'__netxmpp__:disco:items',
				tag => 'item',
				xpath => {
					  JID => { path => '@jid', type=>'jid' },
					  Name => { path => '@name' },
					  Node => { path => '@node' }
					 });

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/disco#info',
				tag=>'query',
				xpath => {
					  Identity => {
						       calls => [ qw/Get Add/ ],
						       type => 'child',
						       path => 'identity',
						       child => { ns => '__netxmpp__:disco:info:identity' }
						  },
					  Feature => {
						      calls => [ qw/Get Add/ ],
						      type => 'child',
						      path => 'feature',
						      child => { ns => '__netxmpp__:disco:info:feature' },
						     },
					  Node => { path => '@node' }
					 });

    $self->Client->AddNamespace(ns=>'__netxmpp__:disco:info:identity',
				tag => 'identity',
				xpath => {
					  Category => { path => '@category' },
					  Type => { path => '@type' },
					  Name => { path => '@name' }
					 });

    $self->Client->AddNamespace(ns=>'__netxmpp__:disco:info:feature',
				tag => 'feature',
				xpath => {
					  Var => { path => '@var' },
					 });

    $self;
  }

use Getopt::Long;

sub cmd_pubsub
  {
    my ($self,$from,$type,$cmd,@args) = @_;

    return "Must be used as 'pubsub'" unless $cmd eq 'pubsub';

    my %opts = (affiliation=>'none',subscription=>'none',help=>0);
    my @opts = ("subid=s","affiliation=s","subscription=s");

    my $usage=<<EOH;
$cmd create      <node>
$cmd delete      <node>
$cmd purge       <node>
$cmd entities    <node>
$cmd setentity   <node> <jid> --subscription=<subscr> --affiliation=<aff>
$cmd subscribe   <node> --subid=<subid>
$cmd unsubscribe <node> --subid=<subid>
$cmd publishers  <node> {<jid>}+
EOH

    my $subcmd = shift @args;
    my $node = shift @args;
    local @ARGV = @args;
    return $usage unless $subcmd && $node;
    return $usage unless GetOptions(\%opts,@opts);

  SWITCH:
    {
      $subcmd eq 'create' and do
	{
	  return $self->Create(Node=>$node)->GetXML();
	},last SWTICH;

      $subcmd eq 'delete' and do
	{
	  return $self->Delete(Node=>$node)->GetXML();
	},last SWTICH;

      $subcmd eq 'purge' and do
	{
	  return $self->Purge(Node=>$node)->GetXML();
	},last SWTICH;

      $subcmd eq 'entities' and do
	{
	  return $self->GetEntities(Node=>$node)->GetXML();
	},last SWTICH;

      $subcmd eq 'setentity' and do {
	my $jid = shift @args;
	return $usage unless $jid;
	$self->SetEntities(Node=>$node,
			   Entities => {
					$jid => { Subscription => $opts{subscription},
						  Affiliation => $opts{affiliation} }
				       }
			   )->GetXML();
      },last SWITCH;

      $subcmd eq 'publishers' and do {

	my $msg = $self->GetEntities(Node=>$node);
	my %sub;
	if ($msg && $msg->GetChild("http://jabber.org/protocol/pubsub"))
	  {
	    my $pubsub = $msg->GetChild("http://jabber.org/protocol/pubsub");
	    foreach my $entity ($pubsub->GetEntities()->GetEntity())
	      {
		$sub{$entity->GetJID()} = $entity->GetSubscription();
	      }
	  }
	
	my %ents;
	foreach my $pub (@args)
	  {
	    $ents{$pub}->{Affiliation} = 'publisher';
	    $ents{$pub}->{Subscription} = $sub{$pub} || 'none';
	  }

	return $self->SetEntities(Node=>$node,Entities=>\%ents)->GetXML();
      },last SWITCH;

      $subcmd eq 'subscribe' and do
	{
	  return $self->Subscribe(Node=>$node,SubID=>$opts{subid})->GetXML();
	},last SWTICH;

      $subcmd eq 'unsubscribe' and do
	{
	  return $self->Unsubscribe(Node=>$node,SubID=>$opts{subid})->GetXML();
	},last SWTICH;
	
      $subcmd eq 'help' and do
	{
	  return "\n$usage";
	}
    };
  }

sub Subscribe
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
	       from=>$self->JID,
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $subscribe = $pubsub->AddSubscribe();
    $subscribe->SetNode($opts{Node});
    $subscribe->SetJID($opts{JID} || $self->JID->GetJID('base'));
    $subscribe->SetSubID($opts{SubID}) if $opts{SubID};

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub Unsubscribe
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
	       from=>$self->JID,
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $subscribe = $pubsub->AddUnsubscribe();
    $subscribe->SetNode($opts{Node});
    $subscribe->SetJID($opts{JID} || $self->JID->GetJID('base'));
    $subscribe->SetSubID($opts{SubID}) if $opts{SubID};

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub Publish
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
	       from=>$self->JID,
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $publish = $pubsub->AddPublish();
    $publish->SetNode($opts{Node} || $self->cfg('PubSub','Node'));
    my $item = $publish->AddItem();
    $item->SetId(defined $opts{Id} ? $opts{Id} : $self->gen_uuid);
    $item->SetContent($opts{Content});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub Create
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
	       from=>$self->JID,
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $create = $pubsub->AddCreate();
    $create->SetNode($opts{Node});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub Delete
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
               from=>$self->JID,
               to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $delete= $pubsub->AddDelete();
    $delete->SetNode($opts{Node});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub Purge
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
               from=>$self->JID,
               to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $purge = $pubsub->AddPurge();
    $purge->SetNode($opts{Node});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub GetEntities
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'get',
               from=>$self->JID,
               to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $entities = $pubsub->AddEntities();
    $entities->SetNode($opts{Node});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub SetEntities
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
               from=>$self->JID,
               to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $entities = $pubsub->AddEntities();
    $entities->SetNode($opts{Node});
    die "Entities option must be a HASH" unless ref $opts{Entities} eq 'HASH';
    foreach my $jid (keys %{$opts{Entities}}) {
        my $entity = $entities->AddEntity();
        $entity->SetJID($jid);
        $entity->SetAffiliation($opts{Entities}->{$jid}->{Affiliation});
        $entity->SetSubscription($opts{Entities}->{$jid}->{Subscription});
    }

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub DiscoverNodes
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();

    $iq->SetIQ(type=>'get',
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $query = $iq->NewChild('http://jabber.org/protocol/disco#items');
    $query->SetNode($opts{Node}) if $opts{Node};

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }


sub DiscoverNode
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();

    $iq->SetIQ(type=>'get',
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $query = $iq->NewChild('http://jabber.org/protocol/disco#info');
    $query->SetNode($opts{Node}) if $opts{Node};

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }


sub initSubscriptions
  {
    my $self = shift;

    if (ref $self->{Subscribe} eq 'ARRAY')
      {
	foreach my $s (@{$self->{Subscribe}})
	  {
	    $self->Subscribe($s->{Host},$s->{Node})
	  }
      }
  }

sub GetFormFieldValue
  {
    my ($self,$msg,$var,$ns) = @_;

    my $q = $msg->GetIQ($ns || 'http://jevent.it.su.se/NS/command');

    return undef unless $q;

    my $form = $q->GetChild('jabber:x:data');
    return undef unless $form;

    return undef unless $form->GetType() eq 'submit';

    foreach my $field ($form->GetField())
      {
	next unless $field->GetVar() eq $var;
	return $field->GetValue();
      }

    undef;
  }

sub SendForm
  {
    JEvent::RequestForm(@_);
  }

sub SubmitForm
  {
    my ($self,%args) = @_;
    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
               from=>$args{From},
               to=>$args{To});

    my $q = $iq->NewChild($args{NS} || 'http://jabber.org/protocol/commands');
    my $form = $q->NewChild('jabber:x:data');
    $form->SetType('submit');
    foreach (@{$args{Fields}})
      {
	my $field = $form->AddField();
	$field->SetVar($_->{Name});
	my @v = ref $_->{Value} eq 'ARRAY' ? @{$_->{Value}} : ($_->{Value});
	foreach my $v (@v)
	  {
	    $field->AddValue($v);
	  }
      }

    $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
  }

sub RequestForm
  {
    my ($self,%args) = @_;
    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'get',
               from=>$args{From},
               to=>$args{To});

    my $q = $iq->NewChild($args{NS} || 'http://jabber.org/protocol/commands');
    my $form = $q->NewChild('jabber:x:data');
    $form->SetTitle($args{Title});
    $form->SetType('form');
    $form->SetInstructions($args{Instructions});
    foreach (@{$args{Fields}})
      {
	my $field = $form->AddField();
	$field->SetVar($_->{Var});
	$field->SetType($_->{Type});
	$field->SetLabel($_->{Label});
	$field->SetDesc($_->{Desc});
	$field->SetRequred($_->{Required});
	my @v = ref $_->{Value} eq 'ARRAY' ? @{$_->{Value}} : ($_->{Value});
	if ($_->{Type} =~ /-multi/)
	  {
	    foreach my $v (@v)
	      {
		$field->AddValue($v);
	      }
	  }
	else
	  {
	    $field->SetValue($v[0]);
	  }
      }

    $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
  }

sub ConfigureNode
  {
    my ($self,%opts) = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'get',
	       from=>$self->JID,
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild('http://jabber.org/protocol/pubsub#owner');
    my $configure = $pubsub->AddConfigure();
    $configure->SetNode($opts{Node});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML();
    $msg;
  }

sub FormHTML
  {
    my ($self,$form,$q,%opts) = @_;

    my $out = "<table class=\"xmpp-form\">\n";
    foreach my $field ($form->GetField())
      {
	$out .= "<tr class=\"xmpp-form-field\">\n";
	$out .= "<td class=\"xmpp-form-label\">".$field->GetLabel()."</td>";
	$out .= "<td class=\"xmpp-form-widget\">";
	my $type = $field->GetType();
	my $var = $field->GetVar();
	my @value = $field->GetValue();
      TYPE:
	{
	  $type eq 'fixed' and do
	    {
	      $out .= join("<br/>",@value);
	    },last TYPE;

	  $type eq 'hidden' and do
	    {
	      $out .= $q->hidden(-name=>$var,-value=>$value[0]);
	    },last TYPE;

	  $type eq 'text-private' and do
	    {
	      $out .= $q->password_field(-name=>$var,-value=>$value[0],size=>30);
	    },last TYPE;

	  $type eq 'boolean' and do
	    {
	      $out .= $q->checkbox(-name=>$var,-checked=>$value[0],-value=>1);
	    },last TYPE;

	  $type eq 'text-single' || $type eq 'jid-single' and do
	    {
	      $out .= $q->textfield(-name=>$var,-default=>$value[0],-size=>30);
	    },last TYPE;

	  $type eq 'text-multiple' || $type eq 'jid-multiple' and do
	    {
	      $out .= $q->textarea(-name=>$var,-default=>join("\n",@value),-rows=>6,-cols=>40);
	    },last TYPE;

	  $type eq 'list-single' || $type eq 'list-multiple' and do
	    {
	      my %lab;
	      my @opt;<commit_msg>*** empty log message ***<commit_after>package JEvent;

use 5.006;
use strict;
use warnings;

require Exporter;
use AutoLoader qw(AUTOLOAD);

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use JEvent ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	
);
our $VERSION = '0.12';

use Net::XMPP qw(Client);
use Net::XMPP::JID;
use Data::UUID;
use Net::SPOCP;
use Sys::Syslog qw(:DEFAULT);
use Config::IniFiles;

sub new
  {
    my $self = shift;
    my $class = ref $self || $self;

    my %me = @_;
    $me{Config} = Config::IniFiles->new() unless UNIVERSAL::isa($me{Config},'Config::IniFiles');

    my $this = bless \%me,$class;
    $this->init();
  }

sub LogWarn
  {
    my($self,$msg,@args) = @_;

    syslog('warning',$msg,@args);
  }

sub LogError
  {
    my($self,$msg,@args) = @_;

    syslog('error',$msg,@args);
  }

sub LogInfo
  {
    my($self,$msg,@args) = @_;

    syslog('info',$msg,@args);
  }

sub LogDebug
  {
    my($self,$msg,@args) = @_;

    syslog('debug',$msg,@args);
  }

sub Client
  {
    $_[0]->{_xmpp};
  }

sub JID
  {
    $_[0]->{_jid}
  }

sub Hostname
  {
    $_[0]->JID->GetServer();
  }

sub Username
  {
    $_[0]->JID->GetUserID();
  }

sub Resource
  {
    $_[0]->JID->GetResource();
  }

sub Password
  {
    my $pw = $_[0]->{Password};
    return $pw if $pw;
    &{$_[0]->{PasswordCB}}($_[0]) if ref $_[0]->{PasswordCB};
    die "Missing Password and/or PasswordCB\n";
  }

sub cfg
  {
    my $self = shift;
    $self->{Config}->val(@_);
  }

sub gen_uuid
  {
    $_[0]->{_ug}->create_str();
  }

sub init
  {
    my $self = shift;

    openlog "JEvent $0","pid",'LOG_USER';

    $self->{_jid} = Net::XMPP::JID->new($self->{JID} || $self->cfg('JEvent','JID'));
    $self->{Timeout} = $self->cfg('JEvent','Timeout') unless $self->{Timeout};
    $self->{Timeout} = 5 unless $self->{Timeout};
    $self->{Password} = $self->cfg('JEvent','Password') unless $self->{Password};
    $self->{_ug} = Data::UUID->new();

    my @opts = ();
    $self->{DebugLevel} = $self->cfg('JEvent','DebugLevel') unless $self->{DebugLevel};
    $self->{DebugFile} = $self->cfg('JEvent','DebugFile') unless $self->{DebugFile};
    push(@opts,debuglevel=>$self->{DebugLevel}) if $self->{DebugLevel};
    push(@opts,debugfile=>$self->{DebugFile}) if $self->{DebugFile};

    $self->{Host} = $self->cfg('PubSub','Host') unless $self->{Host};
    $self->{Node} = $self->cfg('PubSub','Node') unless $self->{Node};
    $self->{Description} = $self->cfg('JEvent','Description') unless $self->{Description};

    $self->{SPOCPServer} = $self->cfg('SPOCP','Server') unless $self->{SPOCPServer};
    $self->{UseTLS} = $self->cfg('JEvent','UseTLS') unless $self->{UseTLS};
    $self->{SSLVerify} = $self->cfg('SSL','verify') unless $self->{SSLVerify};
    $self->{CAFile} = $self->cfg('SSL','cafile') unless $self->{CAFile};
    $self->{CADir} = $self->cfg('SSL','cadir') unless $self->{CADir};
    $self->{ProcessTimeout} = $self->cfg('JEvent','ProcessTimeout');

    $self->{_xmpp} = Net::XMPP::Client->new(@opts);
    $self->Client->SetCallBacks(onauth=>sub
				 {
				   $self->Client->PresenceSend();
				   &{$self->{StartCB}}($self) if ref $self->{StartCB} eq 'CODE';
				 },
				 onprocess=>sub
				 {
				   &{$self->{ProcessCB}}($self) if ref $self->{ProcessCB} eq 'CODE';
				 });

    $self->Client->SetMessageCallBacks(error=>sub
					{
					  #warn $_[1]->GetXML();
					},
					groupchat=>sub
					{
					  &{$self->{MessageCB}}($self,@_) if ref $self->{MessageCB} eq 'CODE';
					},
					normal=>sub
					{
					  &{$self->{MessageCB}}($self,@_) if ref $self->{MessageCB} eq 'CODE';
					},
					chat=>sub
					{
					  &{$self->{MessageCB}}($self,@_) if ref $self->{MessageCB} eq 'CODE';
					});

    $self->Client->SetPresenceCallBacks(subscribe => sub {
					   my $ok = ref $self->{SubscriptionAuthorization} eq 'CODE' ?
					     &{$self->{SubscriptionAuthorization}}($self,@_) : 1;
                                           warn $_[1]->GetXML();
					   if ($ok)
					     {
					       $self->Client->PresenceSend(to=>$_[1]->GetFrom(),type=>'subscribed');
					     }
					   else
					     {
					       $self->Client->PresenceSend(to=>$_[1]->GetFrom(),type=>'unsubscribed');
					     }
					 });

    $self->Client->SetXPathCallBacks("/message/event[\@xmlns=\'http://jabber.org/protocol/pubsub#event\']" => sub
				      {
					&{$self->{EventCB}}($self,@_) if ref $self->{EventCB} eq 'CODE';
				      });

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/pubsub',
				 tag=>'pubsub',
				 xpath=>{
					 Publish => { calls => [qw/Get Add Defined/],
						      type => 'child',
						      path => 'publish',
						      child => { ns => '__netxmpp__:pubsub:publish' } },

					 Retract => { calls => [qw/Get Add Defined/],
						      type => 'child',
						      path => 'retract',
						      child => { ns => '__netxmpp__:pubsub:retract' } },

					 Subscribe => { calls => [qw/Get Add Defined/],
							type => 'child',
							path => 'subscribe',
							child => { ns => '__netxmpp__:pubsub:subscribe' } },

					 Unsubscribe => { calls => [qw/Get Add Defined/],
							  type => 'child',
							  path => 'unsubscribe',
							  child => { ns => '__netxmpp__:pubsub:unsubscribe' } },

					 Entity => { calls => [qw/Get Add Defined/],
						     type => 'child',
						     path => 'entity',
						     child => { ns => '__netxmpp__:pubsub:entity' } },

					 Affiliations => { calls => [qw/Get Add Defined/],
							   type => 'child',
							   path => 'affiliations',
							   child => { ns => '__netxmpp__:pubsub:affiliations' } },

					 Create => { calls => [qw/Get Add Defined/],
					             type => 'child',
					             path => 'create',
						     child => { ns => '__netxmpp__:pubsub:create' } },
					
					 Delete => { calls => [qw/Get Add Defined/],
                                                     type => 'child',
                                                     path => 'delete',
                                                     child => { ns => '__netxmpp__:pubsub:delete' } },

                                         Purge => { calls => [qw/Get Add Defined/],
                                                     type => 'child',
                                                     path => 'purge',
                                                     child => { ns => '__netxmpp__:pubsub:purge' } },

                                         Entities => { calls => [qw/Get Add Defined/],
                                                     type => 'child',
                                                     path => 'entities',
                                                     child => { ns => '__netxmpp__:pubsub:entities' } },

					 Items => { calls => [qw/Get Set/],
						    type => 'child',
						    path => 'items',
						    child => { ns => '__netxmpp__:pubsub:items' } },
					},
				);

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:publish',
				 tag => 'publish',
				 xpath=>{
					 Node => { path => '@node' },
					 Item => { calls => [qw/Get Set Add/],
						   type => 'child',
						   path => 'item',
						   child => { ns => '__netxmpp__:pubsub:publish:item' } }

					},
				);

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:create',
                                tag => 'create',
                                xpath => {
                                          Node => { path => '@node' }
                                         }
                                );

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:delete',
                                tag => 'delete',
                                xpath => {
                                          Node => { path => '@node' }
                                         }
                                );

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:purge',
                                tag => 'purge',
                                xpath => {
                                          Node => { path => '@node' }
                                         }
                                );

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:entities',
                                tag => 'entities',
                                xpath => {
                                          Node => { path => '@node' },
					  Entity => { calls => [qw/Get Set Add/],
					              type => 'child',
						      path => 'entity',
						      child => { ns => '__netxmpp__:pubsub:entity' } }
                                         }
                                );

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:retract',
				 tag => 'retract',
				 xpath=>{
					 Node => { path => '@node' },
					 Item => { calls => [qw/Get Set/],
						   type => 'child',
						   path => 'item',
						   child => { ns => '__netxmpp__:pubsub:retract:item' } }

					},
				);

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:publish:item',
				 tag => 'item',
				 xpath=>{
					 Id => { path => '@id' },
					 Content => { type => 'raw', path => '.' }
					});

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:retract:item',
				 tag => 'item',
				 xpath=>{
					 Id => { path => '@id' },
					});

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:subscribe',
				 tag => 'subscribe',
				 xpath=>{
					 Node => { path => '@node' },
					 SubID => { path => '@subid' },
					 JID => { type => 'jid', path => '@jid' }
					});

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:unsubscribe',
				 tag => 'unsubscribe',
				 xpath=>{
					 Node => { path => '@node' },
					 JID => { type => 'jid', path => '@jid' },
					 SubID => { path => '@subid' }
					});

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:entity',
				 tag => 'entity',
				 xpath=>{
					 Node => { path => '@node' },
					 JID => { type => 'jid', path => '@jid' },
					 Affiliation => { path => '@affiliation' },
					 SubID => { path => '@subid' },
					 Subscription => { path => '@subscription' },
                                         Subscribed => { path => '@subscribed' }
					});

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:affiliations',
				 tag => 'affiliations',
				 xpath => {
					   Entity => { calls => [qw/Get Add Defined/],
						       type => 'child',
						       path => 'entity',
						       child => { ns => '__netxmpp__:pubsub:entity' } }
					  });

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:items',
				 tag => 'items',
				 xpath=>{
					 Node => { path => '@node' },
					 JID => { type => 'jid' },
					 SubID => { path => '@subid' },
					 MaxItems => { path => '@max_items' },
					 Item => { calls => [ qw/Add/],
						   type => 'child',
						   path => 'item',
						   child => { ns => '__netxmpp__:pubsub:item' } },
					 Items => { calls => [ qw/Get/],
						    type => 'child',
						    path => 'item',
						    child => { ns => '__netxmpp__:pubsub:item' } }
					});

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/pubsub#owner',
				tag => 'pubsub',
				xpath => {
					  Configure => { calls => [ qw/Get Add/],
							 type => 'child',
							 path => 'configure',
							 child => { ns => '__netxmpp__:pubsub:owner:configure' } }
					 });

    $self->Client->AddNamespace(ns=>'__netxmpp__:pubsub:owner:configure',
				tag => 'configure',
				xpath => {
					  Node => { path => '@node' },
					  Form => { calls => [ qw /Get Add Defined/ ],
						    type => 'child',
						    path => 'x',
						    child => { ns => 'jabber:x:data' } }
					 });

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/pubsub#event',
				tag => 'event',
				xpath => {
					  Items => { calls => [ qw/Get Add/],
						     type => 'child',
						     path => 'items',
						     child => { ns => '__netxmpp__:pubsub:items' } },
					  Delete => { calls => [ qw/Get Add/],
						      type => 'child',
						      path => 'delete',
						      child => { ns => '__netxmpp__:pubsub:delete' } },
					  Purge => { calls => [ qw/Get Add/],
						     type => 'child',
						     path => 'purge',
						     child => { ns => '__netxmpp__:pubsub:purge' } }
					 });

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/muc',
				 tag => 'x',
				 xpath => {
					   Password => { path => '@password' },
					   Form => { calls => [ qw/Set Defined Get/ ],
						     type => 'child',
						     path => 'x',
						     child => { ns => 'jabber:x:data' } }
					  });

    $self->Client->AddNamespace(ns=>'jabber:x:conference',
				 tag => 'x',
				 xpath => {
					   JID => { path => '@jid', type => 'jid' }
					  });

    $self->Client->AddNamespace(ns=>'http://jevent.it.su.se/NS/command',
				tag => 'command',
				xpath => {
					  Form => { calls => [ qw/Set Defined Get/ ],
						    type  => 'child',
						    path  => 'x',
						    child => { ns => 'jabber:x:data' } }
					 });

    $self->Client->AddNamespace(ns=>'jabber:x:data',
                                tag=>'x',
                                xpath => {
                                           Type => { path => '@type' },
                                           Title => { path => 'title/text()' },
                                           Instructions => { path => 'instructions/text()' },
                                           Field => { calls => [ qw/Get Add/ ],
                                                      type => 'child',
                                                      path => 'field',
                                                      child => { ns => '__netxmpp__:form:field' } }
                                         });

    $self->Client->AddNamespace(ns=>'__netxmpp__:form:field',
                                tag=>'field',
                                xpath => {
					  Type => { path => '@type' },
					  Label => { path => '@label' },
					  Var => { path => '@var' },
					  Value => { path => 'value' },
					  Option => { calls => [ qw /Get Add/ ],
						      type => 'child',
						      path => 'option',
						      child => { ns => '__netxmpp__:form:field:option' }}
                                         });

    $self->Client->AddNamespace(ns=>'__netxmpp__:form:field:option',
				tag=>'option',
				xpath => {
					  Value => { path => 'value' },
					  Label => { path => '@label' }
					 });

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/disco#items',
				tag=>'query',
				xpath => {
					  Item => {
						   calls => [ qw/Get Add/ ],
						   type => 'child',
						   path => 'item',
						   child => { ns => '__netxmpp__:disco:items' }
						  },
					  Node => { path => '@node' }
					 });

    $self->Client->AddNamespace(ns=>'__netxmpp__:disco:items',
				tag => 'item',
				xpath => {
					  JID => { path => '@jid', type=>'jid' },
					  Name => { path => '@name' },
					  Node => { path => '@node' }
					 });

    $self->Client->AddNamespace(ns=>'http://jabber.org/protocol/disco#info',
				tag=>'query',
				xpath => {
					  Identity => {
						       calls => [ qw/Get Add/ ],
						       type => 'child',
						       path => 'identity',
						       child => { ns => '__netxmpp__:disco:info:identity' }
						  },
					  Feature => {
						      calls => [ qw/Get Add/ ],
						      type => 'child',
						      path => 'feature',
						      child => { ns => '__netxmpp__:disco:info:feature' },
						     },
					  Node => { path => '@node' }
					 });

    $self->Client->AddNamespace(ns=>'__netxmpp__:disco:info:identity',
				tag => 'identity',
				xpath => {
					  Category => { path => '@category' },
					  Type => { path => '@type' },
					  Name => { path => '@name' }
					 });

    $self->Client->AddNamespace(ns=>'__netxmpp__:disco:info:feature',
				tag => 'feature',
				xpath => {
					  Var => { path => '@var' },
					 });

    $self;
  }

use Getopt::Long;

sub cmd_pubsub
  {
    my ($self,$from,$type,$cmd,@args) = @_;

    return "Must be used as 'pubsub'" unless $cmd eq 'pubsub';

    my %opts = (affiliation=>'none',subscription=>'none',help=>0);
    my @opts = ("subid=s","affiliation=s","subscription=s");

    my $usage=<<EOH;
$cmd create      <node>
$cmd delete      <node>
$cmd purge       <node>
$cmd entities    <node>
$cmd setentity   <node> <jid> --subscription=<subscr> --affiliation=<aff>
$cmd subscribe   <node> --subid=<subid>
$cmd unsubscribe <node> --subid=<subid>
$cmd publishers  <node> {<jid>}+
EOH

    my $subcmd = shift @args;
    my $node = shift @args;
    local @ARGV = @args;
    return $usage unless $subcmd && $node;
    return $usage unless GetOptions(\%opts,@opts);

  SWITCH:
    {
      $subcmd eq 'create' and do
	{
	  return $self->Create(Node=>$node)->GetXML();
	},last SWTICH;

      $subcmd eq 'delete' and do
	{
	  return $self->Delete(Node=>$node)->GetXML();
	},last SWTICH;

      $subcmd eq 'purge' and do
	{
	  return $self->Purge(Node=>$node)->GetXML();
	},last SWTICH;

      $subcmd eq 'entities' and do
	{
	  return $self->GetEntities(Node=>$node)->GetXML();
	},last SWTICH;

      $subcmd eq 'setentity' and do {
	my $jid = shift @args;
	return $usage unless $jid;
	$self->SetEntities(Node=>$node,
			   Entities => {
					$jid => { Subscription => $opts{subscription},
						  Affiliation => $opts{affiliation} }
				       }
			   )->GetXML();
      },last SWITCH;

      $subcmd eq 'publishers' and do {

	my $msg = $self->GetEntities(Node=>$node);
	my %sub;
	if ($msg && $msg->GetChild("http://jabber.org/protocol/pubsub"))
	  {
	    my $pubsub = $msg->GetChild("http://jabber.org/protocol/pubsub");
	    foreach my $entity ($pubsub->GetEntities()->GetEntity())
	      {
		$sub{$entity->GetJID()} = $entity->GetSubscription();
	      }
	  }
	
	my %ents;
	foreach my $pub (@args)
	  {
	    $ents{$pub}->{Affiliation} = 'publisher';
	    $ents{$pub}->{Subscription} = $sub{$pub} || 'none';
	  }

	return $self->SetEntities(Node=>$node,Entities=>\%ents)->GetXML();
      },last SWITCH;

      $subcmd eq 'subscribe' and do
	{
	  return $self->Subscribe(Node=>$node,SubID=>$opts{subid})->GetXML();
	},last SWTICH;

      $subcmd eq 'unsubscribe' and do
	{
	  return $self->Unsubscribe(Node=>$node,SubID=>$opts{subid})->GetXML();
	},last SWTICH;
	
      $subcmd eq 'help' and do
	{
	  return "\n$usage";
	}
    };
  }

sub Subscribe
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
	       from=>$self->JID,
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $subscribe = $pubsub->AddSubscribe();
    $subscribe->SetNode($opts{Node});
    $subscribe->SetJID($opts{JID} || $self->JID->GetJID('base'));
    $subscribe->SetSubID($opts{SubID}) if $opts{SubID};

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub Unsubscribe
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
	       from=>$self->JID,
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $subscribe = $pubsub->AddUnsubscribe();
    $subscribe->SetNode($opts{Node});
    $subscribe->SetJID($opts{JID} || $self->JID->GetJID('base'));
    $subscribe->SetSubID($opts{SubID}) if $opts{SubID};

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub Publish
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
	       from=>$self->JID,
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $publish = $pubsub->AddPublish();
    $publish->SetNode($opts{Node} || $self->cfg('PubSub','Node'));
    my $item = $publish->AddItem();
    $item->SetId(defined $opts{Id} ? $opts{Id} : $self->gen_uuid);
    $item->SetContent($opts{Content});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub Create
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
	       from=>$self->JID,
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $create = $pubsub->AddCreate();
    $create->SetNode($opts{Node});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub Delete
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
               from=>$self->JID,
               to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $delete= $pubsub->AddDelete();
    $delete->SetNode($opts{Node});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub Purge
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
               from=>$self->JID,
               to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $purge = $pubsub->AddPurge();
    $purge->SetNode($opts{Node});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub GetEntities
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'get',
               from=>$self->JID,
               to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $entities = $pubsub->AddEntities();
    $entities->SetNode($opts{Node});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub SetEntities
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
               from=>$self->JID,
               to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild("http://jabber.org/protocol/pubsub");
    my $entities = $pubsub->AddEntities();
    $entities->SetNode($opts{Node});
    die "Entities option must be a HASH" unless ref $opts{Entities} eq 'HASH';
    foreach my $jid (keys %{$opts{Entities}}) {
        my $entity = $entities->AddEntity();
        $entity->SetJID($jid);
        $entity->SetAffiliation($opts{Entities}->{$jid}->{Affiliation});
        $entity->SetSubscription($opts{Entities}->{$jid}->{Subscription});
    }

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }

sub DiscoverNodes
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();

    $iq->SetIQ(type=>'get',
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $query = $iq->NewChild('http://jabber.org/protocol/disco#items');
    $query->SetNode($opts{Node}) if $opts{Node};

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }


sub DiscoverNode
  {
    my $self = shift;
    my %opts = @_;

    my $iq = Net::XMPP::IQ->new();

    $iq->SetIQ(type=>'get',
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $query = $iq->NewChild('http://jabber.org/protocol/disco#info');
    $query->SetNode($opts{Node}) if $opts{Node};

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML() if $msg;
    $msg;
  }


sub initSubscriptions
  {
    my $self = shift;

    if (ref $self->{Subscribe} eq 'ARRAY')
      {
	foreach my $s (@{$self->{Subscribe}})
	  {
	    $self->Subscribe($s->{Host},$s->{Node})
	  }
      }
  }

sub GetFormFieldValue
  {
    my ($self,$msg,$var,$ns) = @_;

    my $q = $msg->GetIQ($ns || 'http://jevent.it.su.se/NS/command');

    return undef unless $q;

    my $form = $q->GetChild('jabber:x:data');
    return undef unless $form;

    return undef unless $form->GetType() eq 'submit';

    foreach my $field ($form->GetField())
      {
	next unless $field->GetVar() eq $var;
	return $field->GetValue();
      }

    undef;
  }

sub SendForm
  {
    JEvent::RequestForm(@_);
  }

sub SubmitForm
  {
    my ($self,%args) = @_;
    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'set',
               from=>$args{From},
               to=>$args{To});

    my $q = $iq->NewChild($args{NS} || 'http://jabber.org/protocol/commands');
    my $form = $q->NewChild('jabber:x:data');
    $form->SetType('submit');
    foreach (@{$args{Fields}})
      {
	my $field = $form->AddField();
	$field->SetVar($_->{Name});
	my @v = ref $_->{Value} eq 'ARRAY' ? @{$_->{Value}} : ($_->{Value});
	foreach my $v (@v)
	  {
	    $field->AddValue($v);
	  }
      }

    $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
  }

sub RequestForm
  {
    my ($self,%args) = @_;
    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'get',
               from=>$args{From},
               to=>$args{To});

    my $q = $iq->NewChild($args{NS} || 'http://jabber.org/protocol/commands');
    my $form = $q->NewChild('jabber:x:data');
    $form->SetTitle($args{Title});
    $form->SetType('form');
    $form->SetInstructions($args{Instructions});
    foreach (@{$args{Fields}})
      {
	my $field = $form->AddField();
	$field->SetVar($_->{Var});
	$field->SetType($_->{Type});
	$field->SetLabel($_->{Label});
	$field->SetDesc($_->{Desc});
	$field->SetRequred($_->{Required});
	my @v = ref $_->{Value} eq 'ARRAY' ? @{$_->{Value}} : ($_->{Value});
	if ($_->{Type} =~ /-multi/)
	  {
	    foreach my $v (@v)
	      {
		$field->AddValue($v);
	      }
	  }
	else
	  {
	    $field->SetValue($v[0]);
	  }
      }

    $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
  }

sub ConfigureNode
  {
    my ($self,%opts) = @_;

    my $iq = Net::XMPP::IQ->new();
    $iq->SetIQ(type=>'get',
	       from=>$self->JID,
	       to=>$opts{Host} || $self->cfg('PubSub','Host') || $self->Hostname);

    my $pubsub = $iq->NewChild('http://jabber.org/protocol/pubsub#owner');
    my $configure = $pubsub->AddConfigure();
    $configure->SetNode($opts{Node});

    #warn $iq->GetXML();
    my $msg = $self->Client->SendAndReceiveWithID($iq,$self->{Timeout});
    #warn $msg->GetXML();
    $msg;
  }

sub FormHTML
  {
    my ($self,$form,$q,%opts) = @_;

    my $out = "<table class=\"xmpp-form\">\n";
    foreach my $field ($form->GetField())
      {
	$out .= "<tr class=\"xmpp-form-field\">\n";
	my $label = $field->GetLabel() || $field->GetVar();
	$out .= "<td class=\"xmpp-form-label\">$label</td>";
	$out .= "<td class=\"xmpp-form-widget\">";
	my $type = $field->GetType();
	my $var = $field->GetVar();
	my @value = $field->GetValue();

      TYPE:
	{
	  $type eq 'fixed' and do
	    {
	      $out .= join("<br/>",@value);
	    },last TYPE;

	  $type eq 'hidden' and do
	    {
	      $out .= $q->hidden(-name=>$var,-value=>\@value);
	    },last TYPE;

	  $type eq 'text-private' and do
	    {
	      $out .= $q->password_field(-name=>$var,-value=>$value[0],size=>30);
	    },last TYPE;

	  $type eq 'boolean' and do
	    {
	      $out .= $q->checkbox(-name=>$var,-checked=>$value[0],-value=>1);
	    },last TYPE;

	  $type eq 'text-single' || $type eq 'jid-single' and do
	    {
	      $out .= $q->textfield(-name=>$var,-default=>$value[0],-size=>30);
	    },last TYPE;

	  $type eq 'text-multiple' || $type eq 'jid-multiple' and do
	    {
	      $out .= $q->textarea(-name=>$var,-default=>join("\n",@value),-rows=>6,-cols=>40);
	    },last TYPE;

	  $type eq 'list-single' || $type eq 'list-multiple' and do
	    {
	      my %lab;
	      my @opt;
{'fraction_non_alphanumeric': 0.21255602265226, 'fraction_numerical': 0.0013028523781398742, 'mean_word_length': 2.096831459465275, 'pattern_counts': {'":': 0, '<': 47, '<?xml version=': 0, '>': 1738, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 2}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 116, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '387964', 'n_tokens_mistral': 22444, 'n_tokens_neox': 19345, 'n_words': 3473}