Tiarra DCC auto getter

AutoFetch.pm

# -----------------------------------------------------------------------------
# $Id$
# -----------------------------------------------------------------------------
# Auto fetch DCC SEND
# -----------------------------------------------------------------------------
package CTCP::DCC::AutoFetch;
use strict;
use warnings;
use base qw(Module);
use Multicast;
use CTCP;
use Tiarra::Resolver;


sub new {
    my $this = shift->SUPER::new(@_);

    return $this;
}

sub message_arrived {
    my ($this,$msg,$sender) = @_;

    if ($sender->isa('IrcIO::Server') &&
        $msg->command eq 'PRIVMSG') {

        my $text = $msg->param(1);
        foreach my $ctcp (CTCP->extract_from_text("$text")) {
            if ($ctcp =~ m|^DCC (\S*) (.*)$|) {
                my ($type, $params) = (uc($1), $2);
                next unless $type eq 'SEND';

                if (Mask::match_deep([$this->config->mask('all')],$msg->prefix)) {
                        RunLoop->shared->notify_msg("Starting DCC::AutoFetch for $params");
                } else {
                        RunLoop->shared->notify_msg("Not started DCC::AutoFetch because of mask unmatch.");
                        next;
                }

                $this->auto_fetch($msg->clone, $type, $params, $sender);
            }
        }
    }

    $msg;
}

sub intaddr_to_octet {
    my $intaddr = shift;
    my $tail = $intaddr;
    my @ret;
    foreach (0..3) {
        unshift(@ret, $tail % 256);
        $tail /= 256;
    }
    join('.', @ret);
}

sub octet_to_intaddr {
    my $ret = 0;
    foreach (split /\./, shift) {
        $ret *= 256;
        $ret += $_;
    }
    $ret;
}

sub auto_fetch {
    my ($this, $msg, $type, $param, $sender) = @_;
    if ($param !~ /^(\S+) ([\d.]+) (\S+) (\d+)$/) {
        return undef;
    }

    my ($filename, $addr, $port, $size) = ($1, $2, $3, $4);

    $addr = intaddr_to_octet($addr);
    $port =~ s/([0-9]+)/$1/; # sanitizing
    $size =~ s/([0-9]+)/$1/; # sanitizing
    $filename =~ s/\'//g; #'
    $filename =~ s/\`//g; #`
    $filename =~ s/\"//g; #"
    $filename =~ s/\\//g; #\\

    my $nick = $msg->nick;

    my $fetch_command = $this->config->fetch_command;
    my $command = "'$fetch_command' '$nick' '$addr' '$port' '$size' '$filename'";
    system("$command &");
}

1;

=pod
info: DCC SENDを自動でダウンロード
default: off
section: important
# Tiarraが動作しているエンコーディングがUTF-8でないとおそらくちゃんと動作しない

# 取得に使用するコマンド。nick アドレス ポート サイズ ファイル名を受け取る
fetch_command: /usr/local/bin/fetch_dcc.rb

# 受信するマスク。複数指定化。
mask: nick*!*@*.jp
mask: nick2*!*@*.org

=cut