Tagtools.pm

   1 package Tagtools;
   2 use warnings;
   3 use Lingua::EN::Inflect::Number qw(to_PL);
   4 use URI::Escape;
   5 use HTML::TagCloud;
   6 use Carp;
   7 use Cache::FileCache;
   8 use Storable qw(freeze); use MIME::Base64;
   9 use Calendar::Simple;
  10 use Text::Balanced qw(extract_multiple extract_quotelike);
  11
  12 sub import {
  13     my $whence = caller;
  14     my ($class) = @_;
  15     my %cache_options = ( 'namespace' => $whence.'TagTools',
  16                        'default_expires_in' => 600 );
  17     my $cache =
  18        new Cache::FileCache( \%cache_options ) or
  19          croak( "Couldn't instantiate FileCache" );
  20     *{$whence."::zap_cache"} = sub { $cache->Clear };
  21     *{$whence."::do_cached"} = sub {
  22         my ($self, $codeblock,$arg) = @_;
  23         my $key = 0+$codeblock; if ($arg) { $key .=":".encode_base64(freeze(\$arg));  }
  24         my $c = $cache->get($key); return @$c if $c;
  25         my @stuff = $codeblock->($arg);
  26         $cache->set($key, [ @stuff ]);
  27         return @stuff;
  28     };
  29     *{$whence."::_tagcloud"} = sub {
  30         my $cloud = HTML::TagCloud->new();
  31         my $base = $whence->config->uri_base."tag/view/";
  32         for my $tagging (($whence."::Tagging")->search_summary) {
  33             my $name = $tagging->tag->name;
  34             $cloud->add($name, $base.uri_escape($name), $tagging->{count})
  35         }
  36         $cloud
  37     };
  38     *{$whence."::_calendar"} = sub {
  39         my $arg = shift;
  40         require Time::Piece;
  41         my ($y, $m) = split /-/, ($arg || Time::Piece->new->ymd);
  42         my @m = Calendar::Simple::calendar($m, $y);
  43         my @month;
  44         foreach my $week (@m) {
  45             my @weekdays;
  46             foreach my $day (@$week) {
  47                     my $d = { day => $day };
  48                     if ($day) {
  49                         my $tag = "date:$y-$m-".sprintf("%02d", $day);
  50                         my ($x) = ($whence."::SystemTag")->search(name => $tag);
  51                         if ($x) { $d->{tag} = "/system_tag/view/$tag" }
  52                     }
  53                     push(@weekdays, $d);
  54             }
  55             push(@month, \@weekdays);
  56         }
  57         return \@month;
  58     };
  59     for my $thing (qw(tagcloud calendar)) {
  60         *{$whence."::$thing"} = sub { shift->do_cached(\&{$whence."::_".$thing}, @_) }
  61     }
  62     *{$whence."::setup_tagging"} = \&Tagtools::_setup_tagging;
  63 }
  64
  65 sub _setup_tagging {
  66     my ($maypole_class, $target_table, $tag_table_name) = @_;
  67     my $class_for = sub {
  68         $maypole_class->config->model->class_of($maypole_class, shift)
  69     };
  70     $tag_table_name ||= "tag";
  71     my $target = $class_for->($target_table)
  72         || die "Couldn't find a class representing $target_table";
  73     my $via_table = $tag_table_name . "ging";
  74
  75     # Does the tag table exist?
  76     # If not create it or at least moan
  77     # If so configure it as a new class
  78
  79     # At this point, the $via_table should now be able to be named as...
  80     my $tag_class = $class_for->($tag_table_name);
  81     my $via = $tag_class."ging";
  82
  83     # Set up the class
  84     @{$via."::ISA"} = @{$tag_class."::ISA"};
  85     $via->table($via_table);
  86     $via->columns(TEMP => qw/count/);
  87     $via->columns(Essential => "id", $tag_table_name, $target_table);
  88     # Set up the auxilliary methods
  89     $via->set_sql(summary => qq/
  90     SELECT  id, $tag_table_name, count(*) AS count
  91     FROM $via_table
  92     GROUP BY $tag_table_name
  93     ORDER BY count DESC
  94     LIMIT 50
  95     /);
  96     $via->set_sql(all => qq/
  97     SELECT  id, $tag_table_name, count(*) AS count
  98     FROM $via_table
  99     GROUP BY $tag_table_name
 100     ORDER BY count DESC
 101         /);
 102     # Set up the has_many relations
 103     $via->has_a($target_table => $target);
 104     $via->has_a($tag_table_name => $tag_class);
 105     $target->has_many(to_PL($tag_table_name) => [ $via => $tag_table_name ]);
 106     $target->has_many(to_PL($via) => $via);
 107     $tag_class->has_many(to_PL($target_table) => [ $via => $target_table ]);
 108     $tag_class->has_many(to_PL($via_table) => $via);
 109 }
 110
 111 sub separate_tags {
 112     map { s/^"|"$//g; $_}
 113     extract_multiple(
 114         lc $_[1], [
 115             \&extract_quotelike,
 116             qr/([^\s,]+)/
 117         ], undef,1)
 118 }
 119
 120 # THIS IS A HACK
 121
 122 use Time::Seconds;
 123 sub Time::Piece::next_month {
 124     my $tp = shift;
 125     my $month = $tp + ONE_MONTH;
 126     return if $month > Time::Piece->new;
 127     return $month
 128 }
 129 sub Time::Piece::prev_month {
 130     my $tp = shift;
 131     my $month = $tp - ONE_MONTH;
 132     return $month
 133 }
 134
 135 1;