view release on metacpan or  search on metacpan

lib/Bot/Backbone/Service/OFun/Karma.pm  view on Meta::CPAN

    command '!best' => respond_by_method 'best_scores';
    command '!score' => respond_by_method 'best_scores';
    command '!worst' => respond_by_method 'worst_scores';

    command '!score_alias' => given_parameters {
        parameter 'this' => ( match => qr/.+/ );
        parameter 'that' => ( match => qr/.+/ );
    } respond_by_method 'alias_this_to_that';
    command '!score_alias' => given_parameters {
        parameter 'this' => ( match => qr/.+/ );
    } respond_by_method 'show_alias_of_this';
    command '!score_unalias' => given_parameters {
        parameter 'this' => ( match => qr/.+/ );
    } respond_by_method 'unalias_this';

    also not_command spoken run_this_method 'update_scores';
};


sub load_schema {
    my ($self, $conn) = @_;

    $conn->run(fixup => sub {
        $_->do(q[
            CREATE TABLE IF NOT EXISTS karma_score(
                name varchar(255),
                score int,
                PRIMARY KEY (name)
            )
        ]);

        $_->do(q[
            CREATE TABLE IF NOT EXISTS karma_alias(
                name varchar(255),
                score_as varchar(255),
                PRIMARY KEY (name)
            );
        ]);
    });
}


sub ok_name {
    my ($self, $name) = @_;

    # No empty string votes
    return unless $name;

    # No file permissions
    return if $name =~ /^[d-][r-][w-][x-][r-][w-][sx-][r-][w-]?[tx-]?/;

    # And there should be at least a couple word chars
    return unless $name =~ /\w.*?\w/;

    # OK!
    return 1;
}


sub update_scores {
    my ($self, $message) = @_;

    my @args = $message->all_args;
    THING: for my $i (0 .. $#args) {
        my $arg  = $args[$i];
        my $name = $arg->text;

        # word by itself, join it to the previous maybe?
        if ($name eq '++' or $name eq '--') {

            # Can't be postfix ++/-- if it's the first thing
            next THING unless $i > 0;

            # Ignore if there's space between ++/-- and the previous thing
            next THING unless $args[$i-1]->original =~ /\S$/;

            # Looks legit, join the last word to this for the vote
            $name = $args[$i-1]->text . $name;
        }

        if ($name =~ s/(\+\+|--)$//) {
            my $direction = $1 eq '++' ? +1 : -1;

            next THING unless $self->ok_name($name);

            $self->db_conn->txn(fixup => sub {
                $_->do(q[
                    INSERT OR IGNORE INTO karma_score(name, score)
                    VALUES (?, ?)
                ], undef, $name, 0);
            
                $_->do(q[
                    UPDATE karma_score
                       SET score = score + ?
                     WHERE name = ?
                ], undef, $direction, $name);
            });
        }
    }
}


sub score_of_thing {
    my ($self, $message) = @_;

    my $thing = $message->parameters->{thing};

    my ($score) = $self->db_conn->txn(fixup => sub {
        my ($score_as) = $_->selectrow_array(q[
            SELECT score_as
              FROM karma_alias
             WHERE name = ?
        ], undef, $thing);

        $thing = $score_as if defined $score_as;
        my $sth = $_->prepare(q[
            SELECT ks.score + COALESCE(SUM(kas.score), 0)
              FROM karma_score ks
         LEFT JOIN karma_alias ka ON ks.name = ka.score_as
         LEFT JOIN karma_score kas ON ka.name = kas.name