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;