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