Tagtools.pm

   1 package Tagtools;
   2 use HTML::TagCloud;
   3 use Carp;
   4 use Cache::FileCache;
   5 use Storable qw(freeze); use MIME::Base64;
   6 use Calendar::Simple;
   7 sub import {
   8     my $whence = caller;
   9     my ($class) = @_;
  10     my %cache_options = ( 'namespace' => $whence.'TagTools',
  11                        'default_expires_in' => 600 );
  12     my $cache =
  13        new Cache::FileCache( \%cache_options ) or
  14          croak( "Couldn't instantiate FileCache" );
  15     *{$whence."::zap_cache"} = sub { $cache->Clear };
  16     *{$whence."::do_cached"} = sub {
  17         my ($self, $codeblock,$arg) = @_;
  18         my $key = 0+$codeblock; if ($arg) { $key .=":".encode_base64(freeze(\$arg));  }
  19         my $c = $cache->get(0+$codeblock); return @$c if $c;
  20         my @stuff = $codeblock->($arg);
  21         $cache->set(0+$codeblock, [ @stuff ]);
  22         return @stuff;
  23     };
  24     *{$whence."::_tagcloud"} = sub {
  25         my $cloud = HTML::TagCloud->new();
  26         my $base = $whence->config->uri_base."tag/view/";
  27         for my $tagging (($whence."::Tagging")->search_summary) {
  28             my $name = $tagging->tag->name;
  29             $cloud->add($name, $base.uri_escape($name), $tagging->{count})
  30         }
  31         $cloud
  32     };
  33     *{$whence."::_calendar"} = sub {
  34         my $self = shift;
  35         my $arg = shift;
  36         my ($y, $m) = split /-/, ($arg || Time::Piece->new->ymd);
  37         my @m = Calendar::Simple::calendar($m, $y);
  38         my @month;
  39         foreach my $week (@m) {
  40             my @weekdays;
  41             foreach my $day (@$week) {
  42                     my $d = { day => $day };
  43                     if ($day) {
  44                         my $tag = "date:$y-$m-".sprintf("%02d", $day);
  45                         my ($x) = ($whence."::SystemTag")->search(name => $tag);
  46                         if ($x) { $d->{tag} = "/system_tag/view/$tag" }
  47                     }
  48                     push(@weekdays, $d);
  49             }
  50             push(@month, \@weekdays);
  51         }
  52         return \@month;
  53     };
  54     for my $thing (qw(tagcloud calendar)) {
  55         *{$whence."::$thing"} = sub { shift->do_cached($thing, @_) }
  56     }
  57
  58 }
  59
  60
  61 # THIS IS A HACK
  62
  63 use Time::Seconds;
  64 sub Time::Piece::next_month {
  65     my $tp = shift;
  66     my $month = $tp + ONE_MONTH;
  67     return if $month > Time::Piece->new;
  68     return $month
  69 }
  70 sub Time::Piece::prev_month {
  71     my $tp = shift;
  72     my $month = $tp - ONE_MONTH;
  73     return $month
  74 }
  75
  76 1;