X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=src%2FHomeBank.pm;fp=src%2FHomeBank.pm;h=e976610a0d13f0a1b3b9829d7eb5f300c65697ab;hb=5b7b5519d955cd0c99d094ba140514e0a2b73083;hp=0000000000000000000000000000000000000000;hpb=8988b3bef0760b4cab8144715cc3d8f55688861c;p=chaz%2Fhomebank diff --git a/src/HomeBank.pm b/src/HomeBank.pm new file mode 100644 index 0000000..e976610 --- /dev/null +++ b/src/HomeBank.pm @@ -0,0 +1,335 @@ +package HomeBank; + +use warnings FATAL => 'all'; +use strict; + +use Symbol qw/delete_package/; + +=head1 NAME + +HomeBank - Perl plugin bindings for C + +=head1 SYNOPSIS + + # NAME: Example Plugin + + sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + + $self->on( + terminate => sub { + print "Terminating...\n"; + }, + ); + + $self; + } + + sub on_unhandled { + my ($self, $hook_id) = @_; + print "An unhandled hook named '$hook_id' was called.\n"; + } + +=head1 DESCRIPTION + +The C class provides the infrastructure for loading plugins and handling the registration and calling of +hooks. + +=head1 VARIABLES + +=head2 %plugins + +Contains all of the information about each loaded perl plugin. Plugins probably shouldn't mess around with this. + +=cut + +our %plugins; + +=head1 METHODS + +=head2 load_plugin $filepath + +Load a plugin with the given name. Dies if a plugin with the given name cannot be found or if the plugin couldn't +successfully be eval'd. L calls this to load enabled plugins; plugins themselves probably shouldn't ever use +this. + +=cut + +sub load_plugin { + my $filepath = shift; + + my $package = _valid_package_name($filepath); + $plugins{$package} ||= {}; + + my $mtime = -M $filepath; + if (defined $plugins{$package}->{mtime} && $plugins{$package}->{mtime} <= $mtime) { + warn "Already loaded $filepath"; + } else { + delete_package $package if exists $plugins{$package}->{mtime}; + + open my $fh, $filepath or die "Open '$filepath' failed ($!)"; + binmode $fh, 'utf8'; + local $/ = undef; + my $code = <$fh>; + close $fh; + + my $eval = qq/# line 1 "$filepath"\npackage $package; use base 'HomeBank::Plugin'; $code/; + { + my (%plugins, $mtime, $package); + eval "$eval; 1" or die $@; + } + + $plugins{$package}->{mtime} = $mtime; + } + if (!exists $plugins{$package}->{instance}) { + $plugins{$package}->{instance} = $package->new or die "Plugin instantiation failed"; + } +} + +=head2 unload_plugin $filepath + +The opposite of L. + +=cut + +sub unload_plugin { + my $filepath = shift; + my $package = _valid_package_name($filepath); + + return unless exists $plugins{$package}; + + if ($package->can('delete_package_on_unload') && $package->delete_package_on_unload) { + delete $plugins{$package}; + delete_package $package; + } else { + delete $plugins{$package}->{instance}; + delete $plugins{$package}->{hooks}; + } +} + +=head2 execute_action $filepath + +Allow the plugin specified by C<$filepath> to perform an action. This is called when the plugin is "activated" by the +user. Most plugins should run a modal dialog to allow the user to see and edit plugin preferences. + +=cut + +sub execute_action { + my $filepath = shift; + my $package = _valid_package_name($filepath); + + return unless exists $plugins{$package}; + + my $instance = $plugins{$package}->{instance}; + $instance->EXECUTE if $instance && $instance->can('EXECUTE'); +} + +=head2 read_metadata $filepath + +Get the metadata for a plugin without evaluating it. Plugin metadata should be in the first 100 lines of the plugin file +and should look something like this: + + # NAME: Foobar + # VERSION: 0.01 + # ABSTRACT: This plugin does something. + # AUTHOR: John Doe + # WEBSITE: http://acme.tld/ + +=cut + +sub read_metadata { + my $filepath = shift; + + my $package = _valid_package_name($filepath); + $plugins{$package} ||= {}; + + return $plugins{$package}->{metadata} if exists $plugins{$package}->{metadata}; + + my @keywords = qw/name version abstract author website/; + my $keywords = join('|', @keywords); + + my $metadata = {}; + open my $fh, $filepath or die "Open '$filepath' failed ($!)"; + my $count = 0; + for my $line (<$fh>) { + last if 100 < ++$count; + my ($key, $val) = $line =~ /^#[ \t]*($keywords)[ \t]*[=:](.*)/i; + if ($key && $val) { + $val =~ s/^\s*//; + $val =~ s/\s*$//; + $metadata->{lc $key} = $val; + } + } + close $fh; + + $plugins{$package}->{metadata} = $metadata; +} + +=head2 call_hook $hook_id, ... + +Invoke each perl plugins' hook handlers for the given hook. Additional arguments are passed through to each handler. +Plugins shouldn't use this. + +=cut + +sub call_hook { + my $hook = shift; + + $hook =~ s/[.-]/_/g; + + for my $package (keys %plugins) { + my $hooks = ($plugins{$package} ||= {})->{hooks} ||= {}; + my $count = 0; + for my $cb (@{$hooks->{$hook} ||= []}) { + eval { $cb->(@_); 1 } or warn $@; + $count++; + } + if ($count == 0) { + for my $cb (@{$hooks->{unhandled} ||= []}) { + eval { $cb->($hook, @_); 1 } or warn $@; + } + } + } +} + +=head2 register_method_hooks $plugin + +Register hooks defined as methods that begin with `on_'. + +=cut + +sub register_method_hooks { + my $plugin = shift; + my $package = ref $plugin; + + no strict 'refs'; + my %subs = map { $_ =~ /^on_(.+)/ ? ($1 => $_) : () } keys %{"${package}::"}; + use strict 'refs'; + + register_hooks($plugin, %subs); +} + +=head2 register_hooks $plugin, %hooks + +Register hooks for a plugin. + +=cut + +sub register_hooks { + my ($plugin, %hooks) = @_; + my $package = ref $plugin; + + my $hooks = ($plugins{$package} ||= {})->{hooks} ||= {}; + for my $hook (keys %hooks) { + if (!ref($hooks{$hook}) && defined &{"${package}::$hooks{$hook}"}) { + push @{$hooks->{$hook} ||= []}, sub { unshift @_, $plugin; goto &{"${package}::$hooks{$hook}"} }; + } elsif (ref($hooks{$hook}) eq 'CODE') { + push @{$hooks->{$hook} ||= []}, $hooks{$hook}; + } else { + warn "Hook callback is unusable"; + } + } +} + +=head2 unregister_hooks $package, [@hooks] + +Unregister hooks for a package. If no hooks are specified, B hooks will be unregistered. + +=cut + +sub unregister_hooks { + my ($package, @hooks) = @_; + + if (@hooks) { + for my $hook (@hooks) { + (($plugins{$package} ||= {})->{hooks} ||= {})->{$hook} = []; + } + } else { + ($plugins{$package} ||= {})->{hooks} = {}; + } +} + +=head2 _valid_package_name $string + +Turn a string into a valid name of a package. + +=cut + +sub _valid_package_name { + my $str = shift; + $str =~ s|.*?([^/\\]+)\.pl$|$1|; + $str =~ s|([^A-Za-z0-9\/_])|sprintf("_%2x",unpack("C",$1))|eg; + $str =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; + $str =~ s|[/_]|::|g; + "HomeBank::Plugin::$str"; +} + + +package HomeBank::Boolean; + +use overload + '0+' => sub { ${$_[0]} }, + '++' => sub { $_[0] = ${$_[0]} + 1 }, + '--' => sub { $_[0] = ${$_[0]} - 1 }, + fallback => 1; + +package Types::Serialiser::Boolean; +@HomeBank::Boolean::ISA = Types::Serialiser::Boolean::; + + +package HomeBank::Plugin; + +sub new { + my ($class, $self) = (shift, shift || {}); + bless $self, $class; + HomeBank::register_method_hooks($self); + $self; +} + +sub on { + goto &HomeBank::register_hooks; +} + +sub off { + goto &HomeBank::unregister_hooks; +} + + +package HomeBank::Transaction; + +sub datetime { + require DateTime; + require DateTime::Format::Strptime; + my $dt = DateTime->new(shift->date); + $dt->set_formatter(DateTime::Format::Strptime->new(pattern => '%Y-%m-%d')); + $dt; +} + + +=head1 AUTHOR + +Charles McGarvey + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2013 Charles McGarvey. + +This file is part of HomeBank. + +HomeBank is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +HomeBank is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . + +=cut + +1;