Tagtools.pm

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