#!/usr/bin/perl

use Net::OSCAR;
use DBI;

# конфигурационные данные
$MAX_SPEED=512;
$DB_NAME="icq_bot";
$DB_HOST="localhost";
$DB_USER="user";
$DB_PASS="pass";
# UIN администратора бота
$ADM_UIN=999999999; 

# хеш, содержащий имена команд и связанные с ними функции
%functions = ("speed" =>\&speed,
"htftp" => \&htftp,
"showlist" => \&showlist,
"del" => \&del,
"chgprior" => \&chgprior);

# подключение к ICQ серверу
$oscar = Net::OSCAR->new();
# функция-обработчик входящих сообщений
$oscar->set_callback_im_in(\&message_callback);
# здесь поместите свой UIN и пароль
$oscar->signon(666666, "passpasspass") or 
die("Авторизация не удалась!\n");
# бесконечный цикл
$quit = 0;
while(!$quit) { $oscar->do_one_loop(); }

#
# ядро бота
#
sub message_callback {
local($cmd, $params, $result);
local $result = "";
local($client, $uin, $msg) = @_;
$ADM_UIN=new Net::OSCAR::Screenname $ADM_UIN;
# разрешаем управление ботом только с UIN`а $ADM_UIN
return if($uin ne $ADM_UIN);
# получаем имя команды(с префиксом “!”) и её параметры
if(($cmd, $params) = $msg =~ /^\!([^\ ]+)\s*(.*)$/)
{
local $dbh=DBI->connect("DBI:mysql:$DB_NAME:$DB_HOST", 
$DB_USER, $DB_PASS, {RaiseError => 1});
# такая обработка ошибок сократит код работы с БД
# и сделает его более наглядным
eval {$result = exists($functions{$cmd}) ? 
$functions{$cmd}($params) : ""};
if($@) {$result="Error: $@";}
$client->send_im($uin, $result) if $result;
$dbh->disconnect();
}
}

# функция регулировки скорости в %
sub speed {
my ($result, $cmd, $speed);
my $request=$_[0];
# определяем скорость:
$speed=int($request*$MAX_SPEED/100);
# изменяем значение пропускной скорости канала 1:
$cmd="/sbin/ipfw pipe 1 config bw ".$speed."Kbit/s";
system($cmd) ;
$result=`/sbin/ipfw pipe show 1 | head -1`;
return $result;
}

# добавляем новую задачу в очередь закачек
sub htftp {
# аргументы функции – ссылка и необязательное 
# значение приоритета её закачки
my ($link, $prior)=split(/ /, $_[0]);
my $result;
$prior=int($prior);
my $sql="INSERT INTO download_queue 
(add_time, type, link, prior)
VALUES (NOW(), 'htftp', '$link', $prior)";
$dbh->do($sql);
return "Link added!";
}

# функция отображения очереди закачек
sub showlist {
my ($query, $id, $add_time, $link, $prior, $result);
# задания находятся в состоянии ожидания, если не 
# установлено время начала и окончания закачки
$query=$dbh->prepare("SELECT id, add_time, link, prior 
FROM download_queue 
WHERE start_time IS NULL AND end_time IS NULL
ORDER BY prior DESC, add_time");
$query->execute();
while(($id, $add_time, $link, $prior)=
$query->fetchrow_array()) {
$result.="$id\t$add_time\t$link\t$prior\n"
}
$result.="Queue is empty!" if($result=='');
return $result;
}

use POSIX;
# «клонируем» себя
$pid=fork;
exit if $pid;
die "Ошибка fork: $!" unless defined($pid);
# в порожденном процессе переназначаем 
# дескрипторы ввода/вывода/ошибок
for my $handle (*STDIN, *STDOUT, *STDERR) {
open($handle, "+<", "/dev/null");
}
POSIX::setsid();
# назначаем собственный обработчик функций:
$SIG{INT}=$SIG{TERM}=$SIG{HUP}=\&softexit;

sub softexit {
# мягкое завершение ICQ сессии
$oscar->signoff();
$quit=1;
}

#!/usr/bin/perl

use DBI;

# конфигурационные данные
$DB_NAME="icq_bot";
$DB_HOST="localhost";
$DB_USER="user";
$DB_PASS="pass";
$WGET_PATH="/usr/local/bin/wget";

# функции закачки вызываются через хеш 
# (по аналогии с кодом icq_bot.pl)
%functions = ("htftp" => \&htftp);

$quit = 0;
my ($id, $type, $link);
my $dbh=DBI->connect("DBI:mysql:$DB_NAME:$DB_HOST", 
$DB_USER, $DB_PASS, {RaiseError => 1});
# Continue downloading;
while(!$quit) {
eval { 
# выбираем очередной элемент из очереди
my $sql="SELECT id, type, link 
FROM download_queue
WHERE start_time IS NULL AND end_time IS NULL
ORDER BY prior DESC, add_time LIMIT 1";
my $query=$dbh->prepare($sql);
$query->execute();
if($query->rows>0) {
($id, $type, $link)=$query->fetchrow_array();
print "Starting download $id $link $type";
# делаем запись в БД о времени начала закачки
$sql="UPDATE download_queue 
SET start_time=NOW() WHERE id=$id";
$dbh->do($sql);
# вызываем функцию-обработчик для закачек типа $type
$functions{$type}($link);
$sql="UPDATE download_queue 
SET end_time=NOW()
WHERE id=$id";
$dbh->do($sql);
return;
}

# если очередь пуста, 
# то проверяем её каждые 10 секунд
`sleep 10`;
};
if($@) {
print "Error: $@\n";
}
} #end of main body
$dbh->disconnect();

# обработчик http и ftp закачек
sub htftp {
my $link=@_[0];
my $cmd="$WGET_PATH -c $link";
print $cmd;
system("$cmd");
exit $? if($?);
}