Dogcows Code - chaz/homebank/blob - src/HomeBank.pm

   1 package HomeBank;
   2
   3 use warnings FATAL => 'all';
   4 use strict;
   5
   6 use Symbol qw/delete_package/;
   7
   8 =head1 NAME
   9
  10 HomeBank - Perl plugin bindings for C<homebank>
  11
  12 =head1 SYNOPSIS
  13
  14     # NAME: Example Plugin
  15
  16     sub new {
  17         my $class = shift;
  18         my $self  = $class->SUPER::new(@_);
  19
  20         $self->on(
  21             terminate => sub {
  22                 print "Terminating...\n";
  23             },
  24         );
  25
  26         $self;
  27     }
  28
  29     sub on_unhandled {
  30         my ($self, $hook_id) = @_;
  31         print "An unhandled hook named '$hook_id' was called.\n";
  32     }
  33
  34 =head1 DESCRIPTION
  35
  36 The C<HomeBank> class provides the infrastructure for loading plugins and handling the registration and calling of
  37 hooks.
  38
  39 =head1 VARIABLES
  40
  41 =head2 %plugins
  42
  43 Contains all of the information about each loaded perl plugin. Plugins probably shouldn't mess around with this.
  44
  45 =cut
  46
  47 our %plugins;
  48
  49 =head1 METHODS
  50
  51 =head2 load_plugin $filepath
  52
  53 Load a plugin with the given name. Dies if a plugin with the given name cannot be found or if the plugin couldn't
  54 successfully be eval'd. L<homebank> calls this to load enabled plugins; plugins themselves probably shouldn't ever use
  55 this.
  56
  57 =cut
  58
  59 sub load_plugin {
  60     my $filepath = shift;
  61
  62     my $package = _valid_package_name($filepath);
  63     $plugins{$package} ||= {};
  64
  65     my $mtime = -M $filepath;
  66     if (defined $plugins{$package}->{mtime} && $plugins{$package}->{mtime} <= $mtime) {
  67         warn "Already loaded $filepath";
  68     } else {
  69         delete_package $package if exists $plugins{$package}->{mtime};
  70
  71         open my $fh, $filepath or die "Open '$filepath' failed ($!)";
  72         binmode $fh, 'utf8';
  73         local $/ = undef;
  74         my $code = <$fh>;
  75         close $fh;
  76
  77         my $eval = qq/# line 1 "$filepath"\npackage $package; use base 'HomeBank::Plugin'; $code/;
  78         {
  79             my (%plugins, $mtime, $package);
  80             eval "$eval; 1" or die $@;
  81         }
  82
  83         $plugins{$package}->{mtime} = $mtime;
  84     }
  85     if (!exists $plugins{$package}->{instance}) {
  86         $plugins{$package}->{instance} = $package->new or die "Plugin instantiation failed";
  87     }
  88 }
  89
  90 =head2 unload_plugin $filepath
  91
  92 The opposite of L<load_plugin>.
  93
  94 =cut
  95
  96 sub unload_plugin {
  97     my $filepath = shift;
  98     my $package  = _valid_package_name($filepath);
  99
 100     return unless exists $plugins{$package};
 101
 102     if ($package->can('delete_package_on_unload') && $package->delete_package_on_unload) {
 103         delete $plugins{$package};
 104         delete_package $package;
 105     } else {
 106         delete $plugins{$package}->{instance};
 107         delete $plugins{$package}->{hooks};
 108     }
 109 }
 110
 111 =head2 execute_action $filepath
 112
 113 Allow the plugin specified by C<$filepath> to perform an action. This is called when the plugin is "activated" by the
 114 user. Most plugins should run a modal dialog to allow the user to see and edit plugin preferences.
 115
 116 =cut
 117
 118 sub execute_action {
 119     my $filepath = shift;
 120     my $package  = _valid_package_name($filepath);
 121
 122     return unless exists $plugins{$package};
 123
 124     my $instance = $plugins{$package}->{instance};
 125     $instance->EXECUTE if $instance && $instance->can('EXECUTE');
 126 }
 127
 128 =head2 read_metadata $filepath
 129
 130 Get the metadata for a plugin without evaluating it. Plugin metadata should be in the first 100 lines of the plugin file
 131 and should look something like this:
 132
 133     # NAME:     Foobar
 134     # VERSION:  0.01
 135     # ABSTRACT: This plugin does something.
 136     # AUTHOR:   John Doe <jdoe@acme.tld>
 137     # WEBSITE:  http://acme.tld/
 138
 139 =cut
 140
 141 sub read_metadata {
 142     my $filepath = shift;
 143
 144     my $package  = _valid_package_name($filepath);
 145     $plugins{$package} ||= {};
 146
 147     return $plugins{$package}->{metadata} if exists $plugins{$package}->{metadata};
 148
 149     my @keywords = qw/name version abstract author website/;
 150     my $keywords = join('|', @keywords);
 151
 152     my $metadata = {};
 153     open my $fh, $filepath or die "Open '$filepath' failed ($!)";
 154     my $count = 0;
 155     for my $line (<$fh>) {
 156         last if 100 < ++$count;
 157         my ($key, $val) = $line =~ /^#[ \t]*($keywords)[ \t]*[=:](.*)/i;
 158         if ($key && $val) {
 159             $val =~ s/^\s*//;
 160             $val =~ s/\s*$//;
 161             $metadata->{lc $key} = $val;
 162         }
 163     }
 164     close $fh;
 165
 166     $plugins{$package}->{metadata} = $metadata;
 167 }
 168
 169 =head2 call_hook $hook_id, ...
 170
 171 Invoke each perl plugins' hook handlers for the given hook. Additional arguments are passed through to each handler.
 172 Plugins shouldn't use this.
 173
 174 =cut
 175
 176 sub call_hook {
 177     my $hook = shift;
 178
 179     $hook =~ s/[.-]/_/g;
 180
 181     for my $package (keys %plugins) {
 182         my $hooks = ($plugins{$package} ||= {})->{hooks} ||= {};
 183         my $count = 0;
 184         for my $cb (@{$hooks->{$hook} ||= []}) {
 185             eval { $cb->(@_); 1 } or warn $@;
 186             $count++;
 187         }
 188         if ($count == 0) {
 189             for my $cb (@{$hooks->{unhandled} ||= []}) {
 190                 eval { $cb->($hook, @_); 1 } or warn $@;
 191             }
 192         }
 193     }
 194 }
 195
 196 =head2 register_method_hooks $plugin
 197
 198 Register hooks defined as methods that begin with `on_'.
 199
 200 =cut
 201
 202 sub register_method_hooks {
 203     my $plugin = shift;
 204     my $package = ref $plugin;
 205
 206     no strict 'refs';
 207     my %subs = map { $_ =~ /^on_(.+)/ ? ($1 => $_) : () } keys %{"${package}::"};
 208     use strict 'refs';
 209
 210     register_hooks($plugin, %subs);
 211 }
 212
 213 =head2 register_hooks $plugin, %hooks
 214
 215 Register hooks for a plugin.
 216
 217 =cut
 218
 219 sub register_hooks {
 220     my ($plugin, %hooks) = @_;
 221     my $package = ref $plugin;
 222
 223     my $hooks = ($plugins{$package} ||= {})->{hooks} ||= {};
 224     for my $hook (keys %hooks) {
 225         if (!ref($hooks{$hook}) && defined &{"${package}::$hooks{$hook}"}) {
 226             push @{$hooks->{$hook} ||= []}, sub { unshift @_, $plugin; goto &{"${package}::$hooks{$hook}"} };
 227         } elsif (ref($hooks{$hook}) eq 'CODE') {
 228             push @{$hooks->{$hook} ||= []}, $hooks{$hook};
 229         } else {
 230             warn "Hook callback is unusable";
 231         }
 232     }
 233 }
 234
 235 =head2 unregister_hooks $package, [@hooks]
 236
 237 Unregister hooks for a package. If no hooks are specified, B<all> hooks will be unregistered.
 238
 239 =cut
 240
 241 sub unregister_hooks {
 242     my ($package, @hooks) = @_;
 243
 244     if (@hooks) {
 245         for my $hook (@hooks) {
 246             (($plugins{$package} ||= {})->{hooks} ||= {})->{$hook} = [];
 247         }
 248     } else {
 249         ($plugins{$package} ||= {})->{hooks} = {};
 250     }
 251 }
 252
 253 =head2 _valid_package_name $string
 254
 255 Turn a string into a valid name of a package.
 256
 257 =cut
 258
 259 sub _valid_package_name {
 260     my $str = shift;
 261     $str =~ s|.*?([^/\\]+)\.pl$|$1|;
 262     $str =~ s|([^A-Za-z0-9\/_])|sprintf("_%2x",unpack("C",$1))|eg;
 263     $str =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
 264     $str =~ s|[/_]|::|g;
 265     "HomeBank::Plugin::$str";
 266 }
 267
 268
 269 package HomeBank::Boolean;
 270
 271 use overload
 272     '0+'        => sub { ${$_[0]} },
 273     '++'        => sub { $_[0] = ${$_[0]} + 1 },
 274     '--'        => sub { $_[0] = ${$_[0]} - 1 },
 275     fallback    => 1;
 276
 277 package Types::Serialiser::Boolean;
 278 @HomeBank::Boolean::ISA = Types::Serialiser::Boolean::;
 279
 280
 281 package HomeBank::Plugin;
 282
 283 sub new {
 284     my ($class, $self) = (shift, shift || {});
 285     bless $self, $class;
 286     HomeBank::register_method_hooks($self);
 287     $self;
 288 }
 289
 290 sub on {
 291     goto &HomeBank::register_hooks;
 292 }
 293
 294 sub off {
 295     goto &HomeBank::unregister_hooks;
 296 }
 297
 298
 299 package HomeBank::Transaction;
 300
 301 sub datetime {
 302     require DateTime;
 303     require DateTime::Format::Strptime;
 304     my $dt = DateTime->new(shift->date);
 305     $dt->set_formatter(DateTime::Format::Strptime->new(pattern => '%Y-%m-%d'));
 306     $dt;
 307 }
 308
 309
 310 =head1 AUTHOR
 311
 312 Charles McGarvey <chazmcgarvey@brokenzipper.com>
 313
 314 =head1 COPYRIGHT AND LICENSE
 315
 316 This software is copyright (c) 2013 Charles McGarvey.
 317
 318 This file is part of HomeBank.
 319
 320 HomeBank is free software; you can redistribute it and/or modify
 321 it under the terms of the GNU General Public License as published by
 322 the Free Software Foundation; either version 2 of the License, or
 323 (at your option) any later version.
 324
 325 HomeBank is distributed in the hope that it will be useful,
 326 but WITHOUT ANY WARRANTY; without even the implied warranty of
 327 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 328 GNU General Public License for more details.
 329
 330 You should have received a copy of the GNU General Public License
 331 along with this program.  If not, see <http://www.gnu.org/licenses/>.
 332
 333 =cut
 334
 335 1;