Данный скрипт представляет собой Jabber User Directory совместимый с Jabberd2.
В качестве базы данных используется LDAP, основан на скрипте под названием
users-agent(reatmon@jabber.org), где используется MySQL.
Написан для внедрения сервиса на предприятии, где jabber используется как
средство корпоративноо общения.
Механизмы предварительной регистрации, с целью разрешения пользователям найти
себя намеренно отключены.
Все настройки вынесены в заголовок скипта, за исключением двух строк (искать
domain.ru) с указанием домена после @, т.к. руки не дошли вынести в
переменную - думаю исправить в следующих версиях.
К самому скрипту прилогается стартовый скрипт для gentoo.
Скрипт успешно работатет с Psi, в Kopete не работате фильтрация, думаю
вследствие кривизны клиента - т.к. не заполняет должным образом структуру...

Собственно сам скрипт:

#!/usr/bin/perl

##############################################################################
#
# users-agent-LDAP
#
# Позволяет искать пользователей в LDAP и добавлять их в ростер
#
#############################################################################
my $VERSION = "1.0";

$j_directory="jud.domain.ru";
$j_host="127.0.0.1";
$j_port="5347";
$j_secret="pass";
$l_host="127.0.0.1";
$l_base="ou=Users,dc=rnd,dc=domain,dc=local";
$l_filter="(objectClass=posixAccount)";

##############################################################################
#
# Используемые модули Perl
#
##############################################################################
use Net::Jabber 2.0;
use Net::LDAP;
use utf8;
use Getopt::Long;

my %optctl = ();
$optctl{debug} = 0;
&GetOptions(\%optctl, "debug=i","config=s");

my $Debug = new Net::Jabber::Debug(level=>$optctl{debug},
header=>"Organisation");

##############################################################################
#
# Intercept signals so that we can close down gracefully
#
##############################################################################
$SIG{HUP} = \&Stop
$SIG{KILL} = \&Stop
$SIG{TERM} = \&Stop
$SIG{INT} = \&Stop

##############################################################################
#
# Global Variables
#
##############################################################################
my %config;
my @routes;

##############################################################################
#
# Форама поиска
#
##############################################################################
my $searchForm = new Net::Jabber::Stanza("x");
$searchForm->SetXMLNS('jabber:x:data');
$searchForm->SetData(instructions=>'Чтобы найти пользователя введите несколько букв из его предпологаемого идентификатора.',
title=>'User-Agent Search',
type=>'form');
$searchForm->AddField(type=>'text-single',
var=>'nick',
label=>'Идентификатор');

##############################################################################
#
# Подключаемя к серверу LDAP
#
##############################################################################

$ldap = Net::LDAP->new( $l_host, version=>3 ) or die "$@";
$dtb = $ldap->bind ;

##############################################################################
#
# Создание компонента и соединение с сервером
#
##############################################################################
my $Component = new Net::Jabber::Component(debuglevel=>$optctl{debug});

$Component->Info(name=>"LDAP",
version=>$VERSION);

$Component->SetIQCallBacks("jabber:iq:search"=>{
get=>\&iqSearchGetCB,
set=>\&iqSearchSetCB,
},
"http://jabber.org/protocol/disco#info"=>{
get=>\&iqDiscoInfoGetCB,
},
"http://jabber.org/protocol/disco#items"=>{
get=>\&iqDiscoItemsGetCB,
},
);

$Component->Execute(hostname=>$j_host,
port=>$j_port,
secret=>$j_secret,
componentname=>$j_directory,
);

$Debug->Log0("Giving up and exiting...");
exit(0);

##############################################################################
#
# Завершаем работу и сбрасываем соединения
#
##############################################################################
sub Stop
{
$Component->Disconnect();
$ldap->unbind;
exit(0);
}

##############################################################################
#
# iqSearchGetCB - callback for
#
##############################################################################
sub iqSearchGetCB
{
my $sid = shift;
my $iq = shift;
$Debug->Log1("iqSearchGetCB: iq(",$iq->GetXML(),")");

my $fromJID = $iq->GetFrom("jid");

my $iqReply = $iq->Reply(type=>"result");
my $iqReplyQuery = $iqReply->NewQuery("jabber:iq:search");
$iqReplyQuery->SetSearch(instructions=>"Введите предполагаемый id нужного сотрудника.",
nick=>"");

$Debug->Log1("iqSearchGetCB: reply(",$iqReply->GetXML(),")");
$Debug->Log1("iqSearchGetCB: searchForm(",$searchForm->GetXML(),")");
$iqReplyQuery->AddChild($searchForm);

$Debug->Log1("iqSearchGetCB: reply(",$iqReply->GetXML(),")");
$Component->Send($iqReply);
}

##############################################################################
#
# iqSearchSetCB - callback for
#
##############################################################################
sub iqSearchSetCB
{
my $sid = shift;
my $iq = shift;
$Debug->Log1("iqSearchSetCB: iq(",$iq->GetXML(),")");

my $fromJID = $iq->GetFrom("jid");
my $query = $iq->GetChild();

my $iqReply = $iq->Reply(type=>"result");
my $iqReplyQuery = $iqReply->GetChild("jabber:iq:search");

my @commands;

my @xData = $query->GetChild("jabber:x:data");

my $hasForm = 0;
if ($#xData > -1)
{
$hasForm = 1;
my $likeSpeed = "";
foreach my $field ($xData[0]->GetFields())
{
next unless ($field->GetVar() eq "speed");
if ($field->GetValue() eq "slow")
{
h my $field ($xData[0]->GetFields())
{
next if ($field->GetValue() eq "");

next if ($field->GetVar() eq "speed");
}

# Формируем фильтры для запроса
$t_attr=$xData[0]->GetFields()->GetValue();
if ( ! $t_attr=="" ) {$search_attrs="(uid=*".$t_attr."*)";}
else {$search_attrs="";};
}
else {$search_attrs="";};
$Debug->Log1("iqCB: command($command)\n");
$dtb = $ldap->search( # perform a search
base => $l_base,
filter => "(&".$l_filter.$search_attrs.")",
attrs => [ "cn","uid", "mail" ]
);
$dtb->code && die $dtb->error;

my $resultsReport;
if ($hasForm)
{
$resultsReport = $iqReplyQuery->NewX("jabber:x:data");
$resultsReport->SetData(type=>'result',
title=>"Users-Agent Search Results");
my $reported = $resultsReport->AddReported();
$reported->AddField(var=>'jid',
type=>'jid-single',
label=>'JID');
$reported->AddField(var=>'name',
label=>'Имя');
$reported->AddField(var=>'nick',
label=>'Идентификатор');
$reported->AddField(var=>'email',
label=>'Email');
}

my $count = 0;
foreach $ldap_entry ($dtb->entries)
{

if ($hasForm == 0)
{
$iqReplyQuery->AddItem(jid=>$ldap_entry->get_value('uid')."\@domain.ru",
name=>$ldap_entry->get_value('cn'),
nick=>$ldap_entry->get_value('uid'),
email=>$ldap_entry->get_value('mail'));
}
else
{
my $item = $resultsReport->AddItem();
$item->AddField(var=>"jid",
value=>$ldap_entry->get_value('uid')."\@domain.ru");
$item->AddField(var=>"name",
value=>$ldap_entry->get_value('cn'));
$item->AddField(var=>"nick",
value=>$ldap_entry->get_value('uid'));
$item->AddField(var=>"email",
value=>$ldap_entry->get_value('mail'));
}
$count++;
}
$iqReplyQuery->SetTruncated();

$Component->Send($iqReply);
}

##############################################################################
#
# iqDiscoInfoGetCB - callback for disco
#
##############################################################################
sub iqDiscoInfoGetCB
{
my $sid = shift;
my $iq = shift;
$Debug->Log1("iqDiscoGetCB: iq(",$iq->GetXML(),")");
my $fromJID = $iq->GetFrom("jid");

my $iqReply = $iq->Reply(type=>"result");
my $iqReplyQuery = $iqReply->NewQuery("http://jabber.org/protocol/disco#info");
$iqReplyQuery->AddIdentity($j_directory,
type=>"user",
name=>"LDAP"
);
$iqReplyQuery->AddFeature(var=>"jabber:iq:search");

$Debug->Log1("iqDiscoGetCB: reply(",$iqReply->GetXML(),")");
$Component->Send($iqReply);
}

стартовый скрипт для gentoo

#!/sbin/runscript
# Copyright 2007 Oleg Kluchkin
# Distributed under the terms of the GNU General Public License v2

start() {
ebegin "Starting ljud"
start-stop-daemon --background --start --pidfile /var/run/ljud.pid --make-pidfile \
--exec /usr/local/bin/ljud
eend $?
}

stop() {
ebegin "Stopping ljud"
start-stop-daemon --stop --quiet --pidfile /var/run/ljud.pid
eend $?
}

restart() {
svc_stop
svc_start
}