Merge commit 'Memories as 1.3'

[memories.git] / Tagtools.pm

diff --git a/Tagtools.pm b/Tagtools.pm
new file mode 100644 (file)
index 0000000..0fc2529
--- /dev/null
+++ b/Tagtools.pm
@@ -0,0 +1,76 @@
+package Tagtools;
+use HTML::TagCloud;
+use Carp;
+use Cache::FileCache;
+use Storable qw(freeze); use MIME::Base64;
+use Calendar::Simple;
+sub import {
+    my $whence = caller;
+    my ($class) = @_;
+    my %cache_options = ( 'namespace' => $whence.'TagTools',
+                       'default_expires_in' => 600 );
+    my $cache =
+       new Cache::FileCache( \%cache_options ) or
+         croak( "Couldn't instantiate FileCache" );
+    *{$whence."::zap_cache"} = sub { $cache->Clear };
+    *{$whence."::do_cached"} = sub {
+        my ($self, $codeblock,$arg) = @_;
+        my $key = 0+$codeblock; if ($arg) { $key .=":".encode_base64(freeze(\$arg));  }
+        my $c = $cache->get(0+$codeblock); return @$c if $c;
+        my @stuff = $codeblock->($arg);
+        $cache->set(0+$codeblock, [ @stuff ]);
+        return @stuff;
+    };
+    *{$whence."::_tagcloud"} = sub {
+        my $cloud = HTML::TagCloud->new();
+        my $base = $whence->config->uri_base."tag/view/";
+        for my $tagging (($whence."::Tagging")->search_summary) {
+            my $name = $tagging->tag->name;
+            $cloud->add($name, $base.uri_escape($name), $tagging->{count})
+        }
+        $cloud
+    };
+    *{$whence."::_calendar"} = sub {
+        my $self = shift;
+        my $arg = shift;
+        my ($y, $m) = split /-/, ($arg || Time::Piece->new->ymd);
+        my @m = Calendar::Simple::calendar($m, $y);
+        my @month;
+        foreach my $week (@m) {
+            my @weekdays;
+            foreach my $day (@$week) {
+                    my $d = { day => $day };
+                    if ($day) {
+                        my $tag = "date:$y-$m-".sprintf("%02d", $day);
+                        my ($x) = ($whence."::SystemTag")->search(name => $tag);
+                        if ($x) { $d->{tag} = "/system_tag/view/$tag" }
+                    }
+                    push(@weekdays, $d);
+            }
+            push(@month, \@weekdays);
+        }
+        return \@month;
+    };
+    for my $thing (qw(tagcloud calendar)) {
+        *{$whence."::$thing"} = sub { shift->do_cached($thing, @_) }
+    }
+
+}
+
+
+# THIS IS A HACK
+
+use Time::Seconds;
+sub Time::Piece::next_month {
+    my $tp = shift;
+    my $month = $tp + ONE_MONTH;
+    return if $month > Time::Piece->new;
+    return $month
+}
+sub Time::Piece::prev_month {
+    my $tp = shift;
+    my $month = $tp - ONE_MONTH;
+    return $month
+}
+
+1;