Kitteh.pm

Kitteh.pm

package Kitteh;

use strict;
use warnings;

use DBI;
use File::Basename;
use File::HomeDir;
use MIME::Base64;
use UUID::Tiny ':std';
use URI;

our $VERSION = '0.0.1';
our $db_file = File::HomeDir->my_home . "/cat.db";
#our $db_file = '/scratch/zao/cat.db';
our $dsn = "dbi:SQLite:dbname=$db_file";
our $dbh = DBI->connect($dsn, "", "", { RaiseError => 1, AutoCommit => 1 });
our $cat_dir = File::HomeDir->my_home . "/public_html/cats";
our $cat_base = 'http://zao.se/~zao/cats';
#our $cat_base = 'http://www8.cs.umu.se/~zao/cats';

sub db {
    $dbh->do('PRAGMA foreign_keys = ON');
    $dbh->do('CREATE TABLE IF NOT EXISTS source (' .
        'id INTEGER PRIMARY KEY,' .
        'uri TEXT UNIQUE NOT NULL,' .
        'pad TEXT NOT NULL,' .
        'ext TEXT NOT NULL)'
    );
    $dbh->do('CREATE TABLE IF NOT EXISTS seen (' .
        'id INTEGER NOT NULL,' .
        'server TEXT NOT NULL,' .
        'channel TEXT NOT NULL,' .
        'FOREIGN KEY(id) references source(id),' .
        'PRIMARY KEY(id, server, channel))'
    );
}

&db;

sub get {
    my ($channel, $network) = @_;
    my $get_stmt = $dbh->prepare('
    SELECT id,pad,ext
    FROM source
    WHERE id NOT IN (
        SELECT id
        FROM seen
        WHERE server = ? AND channel = ?)
    ORDER BY random()'
    );
    $get_stmt->execute($network, $channel);
    my $ret;
    if (my $ary = $get_stmt->fetch) {
        my ($id, $pad, $ext) = @$ary;
        $ret = "$cat_base/$id$pad$ext";
        my $seen_stmt = $dbh->prepare(
        'INSERT INTO seen VALUES (?, ?, ?)'
        );
        $seen_stmt->execute($id, $network, $channel);
        $seen_stmt->finish;
    }
    $get_stmt->finish;
    return $ret;
}


sub add {
    sub create_suffix {
        substr uuid_to_string(create_uuid(UUID_RANDOM)), 0, 4;
    }

    my ($uri) = @_;
    my $has_stmt = $dbh->prepare('SELECT 1 FROM source WHERE uri = ?');
    $has_stmt->execute($uri);
    if ($has_stmt->fetch) {
        $has_stmt->finish;
        return;
    }

    my $add_stmt = $dbh->prepare('INSERT INTO source VALUES (NULL, ?, ?, ?)');

    my @segs = URI->new($uri)->path_segments;
    my $filename = $segs[$#segs];
    my ($x, $y, $ext) = fileparse($filename, qr/\.[^.]*/);

    my $pad = create_suffix;
    $add_stmt->execute($uri, $pad, $ext);
    my $id = $dbh->last_insert_id("", "", "", "");
    $add_stmt->finish;

    $filename = $cat_dir . "/$id$pad$ext";

    system("wget -O $filename -c $uri");
}

1;

meow.pl

use strict;
use warnings;
use vars qw($VERSION %IRSSI);

use Irssi;
use Irssi::Irc;
use Kitteh;

$VERSION = "0.0.1";
%IRSSI = (
    authors     => "Lars \'zao\' Viklund",
    contact     => "zao\@zao.se",
    name        => "meow",
    license     => "MIT",
    description => "Send an unseen cat link to the current channel",
    changed     => "Thu May 19 13:34:27 CEST 2011",
    changes     => "Initial version."
);

sub cmd_meow {
    my ($data, $server, $witem) = @_;

    if (!$server || !$server->{connected}) {
        Irssi::print("Not connected to server");
        return;
    }

    if ($witem && ($witem->{type} eq "CHANNEL" ||
                   $witem->{type} eq "QUERY")) {
        my $link = Kitteh::get($witem->{name}, $server->{tag});
        if ($link) {
            $witem->command("MSG ".$witem->{name} . " $link");
        } else {
            Irssi::print("Out of cats, refill the supply");
        }
    } else {
        Irssi::print("No active channel/query in window");
    }
}

sub cmd_addcat {
    my ($uri) = @_;
    
    Kitteh::add($uri);
}

Irssi::command_bind('meow', 'cmd_meow');
Irssi::command_bind('addcat', 'cmd_addcat');