Помогите разобраться

Тема в разделе "Perl программирование", создана пользователем GrandMaster, 26 дек 2008.

  1. GrandMaster

    GrandMaster Гость

    Сегодня нашел скрипт на perl:

    <!--shcode--><pre><code class='perl'>#!/usr/bin/perl -w

    # poor man's ICQ group chat implementation
    #
    # Dobrica Pavlinusic <dpavlin@rot13.org> 2005-03-14
    # released under GPL v2 or perl artistic licence

    use strict;
    use Net::OSCAR qw:)standard);
    use YAML qw(LoadFile DumpFile Dump);
    use Text::Iconv;

    # local encoding
    my $encoding = 'ISO-8859-2';

    my $motd = <<_MOTD_;
    Welcome to group ICQ chat.
    Change your name with: !nick [your_name]
    For help type: !help
    _MOTD_

    my $help = <<_HELP_;
    Confused?
    Change your name with !nick [nickname]
    Exit group chat !leave or !exit
    List group members !members or !list
    Invite new member with !invite [uin] [name]
    Turn echo to sender with !echo
    See last messages with !last
    _HELP_

    my $config_file = shift @ARGV || $ENV{'HOME'}.'/.icq-chat';

    # name of buddy group
    my $buddy_group = 'chat';
    my $echo = 0;
    # default DSN for log
    my $dsn = 'dbi:pg:dbname=test';

    my $my_uin;
    my $config;
    my $oscar;
    my $signon_done = 0;

    my $iconv_utf8 = Text::Iconv->new("UTF-8", $encoding);
    my $iconv_utf16 = Text::Iconv->new("UTF-16BE", $encoding);

    $|=1;

    sub readln {
    my $msg = shift || return;
    print "$msg ";
    my $in = <STDIN>;
    chomp($in);
    return $in;
    }

    sub read_config {
    if (-e $config_file) {
    $config = LoadFile($config_file) || die "can't open $config_file: $!";
    $config->{'uin'} ||= readln("group uin:");
    $config->{'passwd'} ||= readln($config->{'uin'}." password:");
    die "configuration file $config_file is corrupt. Erase it to recover.\n" unless ($config->{'uin'} && $config->{'passwd'});
    } else {
    $config->{'uin'} = readln("group uin:");
    $config->{'passwd'} = readln("password:");
    $config->{'members'} = {};
    $config->{'motd'} = $motd;
    }
    $config->{'dsn'} ||= readln("log dns [$dsn]:");
    $config->{'dsn'} ||= $dsn;

    save_config();
    $my_uin = $config->{'uin'};
    }

    sub save_config {
    DumpFile($config_file, $config) || die "can't open $config_file: $!";
    xlog('config', $my_uin, "$config_file updated");
    }

    sub uin2name {
    my $uin = shift || return "uin2name: missing uin";
    return "bot" if ($uin eq $my_uin);
    return $config->{'members'}->{$uin} || "anonymous $uin";
    }

    sub im_in {
    my($oscar, $sender, $message, $is_away) = @_;

    $message =
    $iconv_utf16->convert($message) ||
    $iconv_utf8->convert($message) ||
    $message || return;

    if ($is_away) {
    xlog('away', $sender, $message);
    return;
    } else {
    xlog('im_in', $sender, $message);
    }

    # strip html from message
    $message =~ s#</*(?:html|body|font|b|p)[^>]*?/*>##gsi;

    $config->{'last_sender_t'}->{$sender} = time();
    $config->{'last_t'} = time();

    if ($message =~ m#^!ping\s*(.*)$#) {
    my $stamp = $1;

    $config->{'ping'}->{$sender}->{'rcv'}++;
    $config->{'ping'}->{$sender}->{'rcv_stamp'} = $stamp if ($stamp);
    $config->{'nack_cnt'} = 0;

    $stamp ||= '';
    $stamp .= " -> ".int(time());
    xsend_im($sender, "!pong $stamp") if ($sender ne $my_uin);
    xlog('ping', $sender, $stamp);
    return;
    }


    # make user online and count it's messages
    $config->{'online'}->{$sender}++;

    if ($sender ne $my_uin && # not me (bot)
    ! $config->{'members'}->{$sender} # not member
    ) {
    $config->{'members'}->{$sender} = $sender;
    $config->{'online'}->{$sender}++;
    }

    # seen first time?
    if ($config->{'online'}->{$sender} == 1) {
    # send motd
    xsend_im($sender, $config->{'motd'}) if ($config->{'motd'});
    add_member($sender);
    xlog('add_member', $sender);
    }

    if ($message =~ m#^!nick\s+(.+)\s*$#) {
    $config->{'members'}->{$sender} = $1;
    xsend_im($sender, "Your name will be: $1");
    xlog('nick', $sender, $1);
    save_config();
    return;
    }

    if ($message =~ m#^!invite\s+(\S+)\s+(.+)*\s*$#) {
    my ($uin, $nick) = ($1, $2);
    xsend_im($uin, "Your are joined to chat by ".uin2name($sender).". You screen name is: $nick");
    xsend_im($sender, "You invited $nick [$uin] to join this chat.");
    add_member($uin, $nick);
    xlog('invite', $uin, $nick);
    return;
    }

    if ($message =~ m#^!(?:skip|kick|leave|exit)\s*(\S*)\s*$#) {
    my $uin = $1 || $sender;
    if ($config->{'members'}->{$uin}) {
    if ($uin == $sender) {
    xsend_im($sender, "You left group chat.");
    xlog('leave', $sender);
    } else {
    xsend_im($sender, "You kicked ".uin2name($uin)." out of this group.");
    xlog('leave', $uin, "kicked by $sender [".uin2name($sender)."]");
    }
    remove_member($uin);
    } else {
    xsend_im($sender, "UIN $uin is not member of group");
    }
    return;
    }

    if ($message =~ m#^!config#) {
    read_config();
    xsend_im($sender, "Configuration reloaded.");
    xlog('config', $sender, 'reloaded');
    return;
    }

    if ($message =~ m#^!(?:members*|list)#) {
    my $members = join(", ",
    map { uin2name($_) } keys %{ $config->{'online'} }
    );
    xsend_im($sender, "Group members: $members");
    xlog('members', $sender, $members);
    return;
    }

    if ($message =~ m#^!help#) {
    xsend_im($sender, $help);
    xlog('help', $sender);
    return;
    }

    if ($message =~ m#^!fortune#) {
    my $text = `fortune` || "Can't guess your fortune.";
    chomp($text);
    xsend_im($sender, $text);
    xlog('fortune', $sender, $text);
    return;
    }

    if ($message =~ m#^!debug#) {
    my $debug = Dump($config);
    $debug =~ s/^passwd:.*$/passwd removed/m;
    xsend_im($sender, $debug);
    xlog('debug', $sender, $debug);
    return;
    }

    if ($message =~ m#^!info\s+(\S+)\s*$#) {
    my $uin = $1;
    my $info = Dump($oscar->buddy($uin)) || "Can't get info for $uin [".uin2name($uin)."]";
    xsend_im($sender, $info);
    xlog('info', $sender, $info);
    return;
    }

    if ($message =~ m#^!on-*line\s*(\S*)\s*$#) {
    my $uin = $1;
    xlog('online', $sender, $uin);
    if ($uin && $config->{'members'}->{$uin}) {
    $config->{'online'}->{$uin}++;
    xsend_im($sender, "Changed status of $uin to on-line.");
    } elsif ($uin) {
    xsend_im($sender, "UIN $uin is not member. Try !invite $uin [name] first");
    } else {
    # check and list on-line members
    xsend_im($sender, "on-line members: ".
    join(", ", map { uin2name($_) } online_uins($oscar) ));
    }
    return;
    }

    if ($message =~ m#^!(?:broadcast|all)#) {
    foreach my $uin (keys %{$config->{'members'}}) {
    $config->{'online'}->{$uin} = 1 unless ($config->{'online'}->{$uin});
    }
    xsend_im($sender, "Your next message will be broadcasted to all members without regard to on-line flag.");
    xlog('broadcast', $sender);
    }

    if ($message =~ m#^!echo#) {
    my $own;
    my $echo = $config->{'echo'}->{$sender};
    if ($echo) {
    $own = "not sent back";
    delete($config->{'echo'}->{$sender});
    } else {
    $own = "sent back to sender";
    $config->{'echo'}->{$sender}++;
    }
    xsend_im($sender, "own messages are $own");
    xlog('echo', $sender, $echo);
    save_config();
    return;
    }

    if ($message =~ m#^!last\s*?(\d*)$#) {
    my $nr = $1;
    xsend_im($sender, "\n".xlast($nr));
    xlog('last', $sender);
    return;
    }

    if ($message =~ m#^!rmskip\s+(\S+)\s*$#) {
    my $uin = $1;
    my $who = uin2name($uin)." [$uin]";

    if ($config->{'skip_buddy'}->{$uin}) {
    delete $config->{'skip_buddy'}->{$uin};
    xsend_im($sender, "removed $who from skip list");
    xlog('rmskip', $sender, $uin);
    } else {
    xsend_im($sender, "can't remove $who from skip list, not a member");
    }
    return;
    }

    $message =~ s#&lt;br&gt;#\n#gis;

    if ($message =~ m#^!motd\s*?(.*)#s) {
    $config->{'motd'} = $1 || $motd;
    xsend_im($sender, "New MOTD is:\n".$config->{'motd'});
    save_config();
    xlog('motd', $sender);
    return;
    }

    xlog('msg', $sender, $message);

    if ($message =~ m#^(!.*)#) {
    xsend_im($sender, "Unknown command: $1");
    xlog("unkown", $sender, $1);
    return;
    }

    # prefix with name
    if ($sender ne $my_uin) {
    my $m = $message || return;
    $message = "[".uin2name($sender)."] $m";
    }

    foreach my $uin (keys %{$config->{'online'}}) {
    next if (! $config->{'echo'}->{$sender} && $uin eq $sender || $uin eq $my_uin);
    xsend_im($uin, $message);
    }
    print "\n";
    }

    sub xsend_all_except {
    my $sender = shift || return;
    my $message = shift || return;
    foreach my $uin (keys %{$config->{'online'}}) {
    # don't send to sender or bot
    next if ($uin eq $sender or $uin eq $my_uin);
    xsend_im($uin, $message);
    }
    }

    sub buddy_in {
    my ($oscar, $uin) = @_;
    warn "buddy in got empty uin\n" and return unless ($uin);
    return if ($uin eq $my_uin);
    $config->{'online'}->{$uin}++;
    xsend_all_except($uin, uin2name($uin)." joined chat.") if ($config->{'online'}->{$uin} == 1);
    xlog('buddy_in', $uin);
    save_config();
    }

    sub buddy_out {
    my ($oscar, $uin) = @_;
    return if ($uin eq $my_uin); # me?
    delete($config->{'online'}->{$uin});
    xsend_all_except($uin, uin2name($uin)." left chat.");
    xlog('buddy_out', $uin);
    save_config();
    }

    my $buddylist_commit_active = 0;

    sub remove_member($) {
    my $uin = shift || return;
    delete ($config->{'online'}->{$uin});
    $oscar->remove_buddy($buddy_group, $uin);
    $oscar->commit_buddylist() if ($buddylist_commit_active == 0);
    $buddylist_commit_active++;
    xlog('remove_member', $uin);
    }

    sub add_member($$) {
    my ($uin, $nick) = @_;
    return unless ($uin && $nick);
    $config->{'members'}->{$uin} = $nick;
    $oscar->add_buddy($buddy_group, $uin);
    $oscar->add_permit($uin);
    $oscar->commit_buddylist() if ($buddylist_commit_active == 0);
    $buddylist_commit_active++;
    xlog('add_member', $uin);
    }

    sub buddylist_ok {
    my $oscar = shift;
    print "Buddy list commited with $buddylist_commit_active changes commited.\n";
    $buddylist_commit_active = 0;
    save_config();
    xlog('buddylist_ok', $my_uin);
    }

    sub buddylist_error {
    my ($oscar, $error, $what) = @_;
    if ($error = 14 && $what =~ m/(\d+)/) {
    my $uin = $1;
    print "ERROR: $what [$error], adding $uin [",uin2name($uin),"] to skip buddy list\n";
    $config->{'skip_buddy'}->{$uin}++;
    remove_member($uin);
    } else {
    print "ERROR: Buddy list commit failed [$error]: $what\n";
    }
    xlog('buddylist_error', $my_uin, $what);
    }

    sub online_uins($) {
    my $oscar = shift || return;
    my @online;
    $config->{'online'} = {};
    foreach my $uin (keys %{$config->{'members'}}) {
    next if ($uin eq $my_uin);
    my $info = $oscar->buddy($uin);
    if ($info->{'online'}) {
    $config->{'online'}->{$uin}++;
    push @online, $uin;
    }
    }
    xlog('online_uins', $my_uin, join(", ", @online));
    save_config();
    return @online;
    }

    sub signon_done {
    my $oscar = shift;
    my @buddies = $oscar->buddies();
    print "adding buddies:\n";
    foreach my $uin (keys %{$config->{'members'}}) {
    my $status = 'old';
    unless (grep(/^$uin$/, @buddies)) {
    if ($config->{'skip_buddy'}->{$uin}) {
    $status = 'SKIPPED';
    } else {
    $oscar->add_buddy($buddy_group, $uin);
    $oscar->set_buddy_alias($buddy_group, $uin, uin2name($uin));
    $status = 'NEW';
    }
    }
    printf("%-10d : %s - %s buddy\n",
    $uin,
    uin2name($uin),
    $status,
    );
    xlog('signon_done', $uin, $status);
    }

    # fixup (just in case) -- remove own uin from members and buddies
    my $me = $my_uin;
    $oscar->remove_buddy($buddy_group, $config->{$me});
    delete($config->{'members'}->{$me});

    $oscar->commit_buddylist();

    print "on-line buddies:\n";
    $config->{'online'} = {};
    foreach my $uin (online_uins($oscar)) {
    printf("%-10d : %s online\n", $uin, uin2name($uin));
    }
    save_config();

    $signon_done++;
    }

    sub rate_alert {
    my ($oscar, $level, $clear, $window, $worrisome) = @_;

    my $msg = "$window messages max in $clear ms limit reached";

    xlog('rate_alter', $my_uin, $level . " " . $msg);

    print "# $msg - sleeping $clear ms\n";
    select(undef, undef, undef, ($clear/100));

    # if ($worrisome) {
    # xsend_im($my_uin, $msg);
    # }
    }

    sub error {
    my ($oscar, $connection, $error, $description, $fatal) = @_;

    xlog('error', $my_uin, $description);
    print "ERROR [$error]: $description\n";

    if ($fatal) {
    $signon_done = 0;
    print "# repeating sign-on\n";
    $oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";
    }

    }

    ## DSN logging support

    my ($dbh,$sth_log, $sth_sent, $sth_sent_ok, $sth_last);

    sub create_log_table {
    $dbh ||= connect_db();
    return unless ($dbh);

    # exit if table exists
    return if ($dbh->do("select * from log limit 1"));

    print "# creating log table in $dsn\n";
    $dbh->do(q{
    create table log (
    id serial,
    date timestamp default now(),
    bot text not null,
    type text not null,
    uin text not null,
    name text not null,
    message text,
    primary key(id)
    )
    }) || die $dbh->errstr();
    $dbh->do(qq{ create index log_date on log(date) }) or die $dbh->errstr();
    $dbh->do(qq{ create index log_bot on log(bot) }) or die $dbh->errstr();
    $dbh->do(qq{ create index log_type on log(type) }) or die $dbh->errstr();
    $dbh->do(qq{ create index log_uin on log(uin) }) or die $dbh->errstr();
    $dbh->do(qq{ create index log_name on log(name) }) or die $dbh->errstr();
    $dbh->do(qq{
    create table sent (
    date timestamp default now(),
    bot text not null,
    uin text not null,
    name text not null,
    r_id text not null,
    message text,
    sent boolean default false,
    primary key(r_id)
    )
    });
    }

    sub connect_db {
    return unless ($config->{'dsn'});
    return if ($dbh);

    require DBI;
    print "# using $dsn for log\n";
    $dbh = DBI->connect($config->{'dsn'},"","") || die $DBI::errstr;

    return $dbh;
    }

    sub xlog {
    my ($type,$uin, $message) = @_;

    my $name = uin2name($uin);

    print localtime()." $type: $uin [$name] ", ( $message || '' ),"\n";

    return unless ($dbh);

    $sth_log ||= $dbh->prepare(qq{
    insert into log (bot,type,uin,name,message) values (?,?,?,?,?)
    }) || die $dbh->errstr();

    $sth_log->execute($my_uin, $type, $uin, $name, $message) || print "$type: [$uin] $message";
    }

    sub xsend_im {
    my ($who, $message, $away) = @_;

    my $r_id = $oscar->send_im($who, $message, $away);
    print "# sent $who $r_id\n";

    return unless ($dbh);

    if (! $r_id) {
    xlog('error', $my_uin, "failed send_im to $who: $message");
    return;
    }

    $sth_sent ||= $dbh->prepare(qq{
    insert into sent (bot,uin,name,r_id,message) values (?,?,?,?,?)
    }) || die $dbh->errstr();
    $sth_sent->execute($my_uin, $who, uin2name($who), $r_id, $message) ||
    xlog('error', $my_uin, "insert of sent $who $r_id failed");
    }

    sub im_ok {
    my ($oscar, $to, $r_id) = @_;
    print "# im_ok $to $r_id\n";

    return unless ($dbh);

    # oh, there seem to be bug in Net::OSCAR. It returns totally off-sync
    # request_id, so I just ack last send messages.
    $sth_sent_ok ||= $dbh->prepare(qq{
    update sent set sent = true where
    bot = ? and uin = ? and r_id =
    (select r_id from sent as s2 where s2.uin = sent.uin and s2.sent = false order by s2.date desc limit 1)
    }) || die $dbh->errstr();

    $sth_sent_ok->execute($my_uin, $to) ||
    xlog('error', $my_uin, "insert of im_ok $to $r_id failed");
    }

    sub xlast {
    my $nr = shift;
    $nr ||= 10; # default: show last 10 messages

    return 'last not supported without database support' unless ($dbh);

    $sth_last ||= $dbh->prepare(qq{
    select date,name,message from log where type = 'msg' and bot = ? order by date desc limit ?
    }) || die $dbh->errstr();

    $sth_last->execute($my_uin, $nr) ||
    xlog('error', $my_uin, "last failed") && return 'last failed';

    my @last;
    my $last_date = '';

    while (my $row = $sth_last->fetchrow_hashref() ) {
    my ($date, $time);
    if( $row->{'date'} =~ m#^(\d+-\d+-\d+)\s(\d+:\d+:\d+)# ) {
    ($date,$time) = ($1,$2);
    if ($date ne $last_date) {
    unshift @last, "date: $date";
    $last_date = $date;
    }
    }

    $time ||= "unknown";

    unshift @last, "($time) [".$row->{'name'}."] ".$row->{'message'};
    }

    return join("\n", @last);
    }


    $oscar = Net::OSCAR->new(capabilities => [qw(extended_status typing_status)]) || die;
    $oscar->loglevel(3);

    read_config();
    create_log_table();

    $oscar->set_callback_im_in(\&im_in);
    $oscar->set_callback_im_ok(\&im_ok);
    $oscar->set_callback_buddy_in(\&buddy_in);
    $oscar->set_callback_buddy_out(\&buddy_out);
    $oscar->set_callback_buddylist_ok(\&buddylist_ok);
    $oscar->set_callback_buddylist_error(\&buddylist_error);
    $oscar->set_callback_signon_done(\&signon_done);
    $oscar->set_callback_rate_alert(\&rate_alert);

    $oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";

    my $interval = 3600;
    my $signoff_i = 5;

    $config->{'last_t'} = time();
    $config->{'nack_cnt'} = 0;

    while(1) {
    $oscar->do_one_loop();

    next unless ($signon_done);

    my $last_t = $config->{'last_t'} || die "no last_t?";

    my $dt = time() - $last_t;
    if ($dt >= $interval) {

    my $nack_cnt = $config->{'nack_cnt'}++;
    print "# dt[$nack_cnt]: $dt\n";

    if ($nack_cnt < $signoff_i) {
    print "# ping keep-alive timeout: $dt s - sending ping, count: $nack_cnt\n";
    xsend_im($my_uin, "!ping ".int(time()) );
    $config->{'last_t'} = time();
    } else {
    print "# serious problems!\n";
    $config->{'nack_cnt'} = 0;

    # $oscar->signoff;
    # $signon_done = 0;
    # $oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";
    }
    }

    }

    # make strict happy
    $DBI::errstr++;[/CODE]
    - это icq чат бот, т.е. позволяет в icq общатся не 2, а более человекам, но я не могу настроить в нем кодировку, ставлю <!--shcode--><pre><code class='perl'>my $encoding = cp1251[/CODE], а он абра-кодабру выводит.

    Помогите кто понял.

    З.Ы.: И еще один вопрос, он выводит последние сообщения по команде !last, а как сделать что бы он выводил каждое сообщение сразу, т.е. если кто то отправит сообщение, оно сразу приходило другим.
     
  2. Vovochka

    Vovochka Гость

    Код (Text):
    my $iconv_utf8 = Text::Iconv->new("UTF-8", $encoding);
    my $iconv_utf16 = Text::Iconv->new("UTF-16BE", $encoding);
    ...
    $message =
    $iconv_utf16->convert($message) ||
    $iconv_utf8->convert($message) ||
    $message || return;
    Скрипт пытается конвертировать из UTF в $encode.
    Точно ли данные ему поступают в utf?
    С другой стороны, при неудачи он должен отдать $message как есть.
    Вам стоит поковыряться в этом куске кода. Посмотреть, где как проходит конвертирование.
     
  3. GrandMaster

    GrandMaster Гость

    А может ли проблема заключаться в терминале, в котором я запускаю скрипт(использую gnome-terminal)?
     
  4. Vovochka

    Vovochka Гость

    Ну дак скорее всего терминал настроен на то чтобы отображать utf8 (системная локаль какая?) Конечно он не будет показывать нормально cp1251.
     
  5. GrandMaster

    GrandMaster Гость

    Пробовал менять кодировку терминала - не помогло, менял также $encode на cp1251, тоже не помогает((
    А можно ли вообще убрать конвертирование кодировок из скрипта?, предположим что б скрипт принимал и отсылал сообщения в cp1251?


    А может ли ошибка заключаться в кодировке базы даннх(PostgreSQL)?, Пробовал выбрать кодировку при создании новой базы cp1251, cp-1251 не проходять, мол не известная кодировка, попробовал windows-1251, выдало следующую ошибку:

    "Ошибка при создании базы данных : Ошибка SQL create database chat encoding = 'WIN1251' : encoding WIN1251 does not match server's locale ru_RU.UTF-8"

    Если все же ошибка из-за кодировки базы данных, можно ли сделать так, что бы в нее записывались сконвертированные сообщения в юникоде?

    Походу у меня база данных с кодировкой UTF-8
     
  6. Vovochka

    Vovochka Гость

    По ходу блин... Разберитесь для начала с входными данными. В какой они кодировке?
    В какой база... С таким-то подходом еще долго можно подбирать параметры перекодирования.
     
  7. GrandMaster

    GrandMaster Гость

    А может проблема заключается в базе данныхPostgreSQL), походу у меня на ней стоит кодировка UTF-8, пробовал ставить кодировку windows-1251, выдает следующую ошибку:

    Ошибка при создании базы данных : Ошибка SQL create database chat with owner="jura" encoding = 'windows-1251' : encoding WIN1251 does not match server's locale ru_RU.UTF-8.

    Нельзя ли сделать так что бы сообщения сразу конвертировались из cp-1251 в юникод и записывались в БД, потом считывались и обратно конвертировались в cp-1251?

    P.S.: Снаступающим всех)))
     
  8. GrandMaster

    GrandMaster Гость

    ДА. Это из-за кодировки БД. Так как если послать команду !дфые(именно русские буквы), в ответ вернется

    Unknown command: !дфые, значит русские буквы проходят.

    а вот при запросе последних сообщений возникают проблемы с русскими буквами)
     
Загрузка...

Поделиться этой страницей