root/trunk/Tagtools.pm

package Tagtools;
use warnings;
use Lingua::EN::Inflect::Number qw(to_PL);
use URI::Escape;
use HTML::TagCloud;
use Carp;
use Cache::FileCache;
use Storable qw(freeze); use MIME::Base64;
use Calendar::Simple;
use Text::Balanced qw(extract_multiple extract_quotelike);

sub import {
    my $whence = caller;
    my ($class) = @_;
    my %cache_options = ( 'namespace' => $whence.'TagTools',
                       'default_expires_in' => 600 );
    my $cache =
       new Cache::FileCache( \%cache_options ) or
         croak( "Couldn't instantiate FileCache" );
    *{$whence."::zap_cache"} = sub { $cache->Clear };
    *{$whence."::do_cached"} = sub {
        my ($self, $codeblock,$arg) = @_;
        my $key = 0+$codeblock; if ($arg) { $key .=":".encode_base64(freeze(\$arg));  }
        my $c = $cache->get($key); return @$c if $c;
        my @stuff = $codeblock->($arg);
        $cache->set($key, [ @stuff ]);
        return @stuff;
    };
    *{$whence."::_tagcloud"} = sub {
        my $cloud = HTML::TagCloud->new();
        my $base = $whence->config->uri_base."tag/view/";
        for my $tagging (($whence."::Tagging")->search_summary) {
            my $name = $tagging->tag->name;
            $cloud->add($name, $base.uri_escape($name), $tagging->{count})
        }
        $cloud
    };
    *{$whence."::_calendar"} = sub {
        my $arg = shift;
        require Time::Piece;
        my ($y, $m) = split /-/, ($arg || Time::Piece->new->ymd);
        my @m = Calendar::Simple::calendar($m, $y);
        my @month;
        foreach my $week (@m) {
            my @weekdays;
            foreach my $day (@$week) {
                    my $d = { day => $day };
                    if ($day) {
                        my $tag = "date:$y-$m-".sprintf("%02d", $day);
                        my ($x) = ($whence."::SystemTag")->search(name => $tag);
                        if ($x) { $d->{tag} = "/system_tag/view/$tag" }
                    }
                    push(@weekdays, $d);
            }
            push(@month, \@weekdays);
        }
        return \@month;
    };
    for my $thing (qw(tagcloud calendar)) {
        *{$whence."::$thing"} = sub { shift->do_cached(\&{$whence."::_".$thing}, @_) }
    }
    *{$whence."::setup_tagging"} = \&Tagtools::_setup_tagging;
}

sub _setup_tagging {
    my ($maypole_class, $target_table, $tag_table_name) = @_;
    my $class_for = sub {
        $maypole_class->config->model->class_of($maypole_class, shift)
    };
    $tag_table_name ||= "tag";
    my $target = $class_for->($target_table) 
        || die "Couldn't find a class representing $target_table";
    my $via_table = $tag_table_name . "ging";

    # Does the tag table exist?
    # If not create it or at least moan
    # If so configure it as a new class

    # At this point, the $via_table should now be able to be named as...
    my $tag_class = $class_for->($tag_table_name);
    my $via = $tag_class."ging";

    # Set up the class
    @{$via."::ISA"} = @{$tag_class."::ISA"};
    $via->table($via_table);
    $via->columns(TEMP => qw/count/);
    $via->columns(Essential => "id", $tag_table_name, $target_table);
    # Set up the auxilliary methods
    $via->set_sql(summary => qq/
    SELECT  id, $tag_table_name, count(*) AS count
    FROM $via_table
    GROUP BY $tag_table_name
    ORDER BY count DESC
    LIMIT 50
    /);
    $via->set_sql(all => qq/
    SELECT  id, $tag_table_name, count(*) AS count
    FROM $via_table
    GROUP BY $tag_table_name
    ORDER BY count DESC
        /);
    # Set up the has_many relations
    $via->has_a($target_table => $target);
    $via->has_a($tag_table_name => $tag_class);
    $target->has_many(to_PL($tag_table_name) => [ $via => $tag_table_name ]);
    $target->has_many(to_PL($via) => $via);
    $tag_class->has_many(to_PL($target_table) => [ $via => $target_table ]);
    $tag_class->has_many(to_PL($via_table) => $via);
}

sub separate_tags {
    map { s/^"|"$//g; $_} 
    extract_multiple(
        lc $_[1], [ 
            \&extract_quotelike, 
            qr/([^\s,]+)/ 
        ], undef,1)
}

# THIS IS A HACK

use Time::Seconds;
sub Time::Piece::next_month {
    my $tp = shift;
    my $month = $tp + ONE_MONTH;
    return if $month > Time::Piece->new;
    return $month
}
sub Time::Piece::prev_month {
    my $tp = shift;
    my $month = $tp - ONE_MONTH;
    return $month
}

1;