Tagtools.pm

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