File Coverage

blib/lib/KelpX/Hooks.pm
Criterion Covered Total %
statement 33 33 100.0
branch 5 8 62.5
condition n/a
subroutine 9 9 100.0
pod 1 1 100.0
total 48 51 94.1


line stmt bran cond sub pod time code
1             package KelpX::Hooks;
2              
3 1     1   101787 use strict;
  1         3  
  1         30  
4 1     1   5 use warnings;
  1         2  
  1         28  
5 1     1   5 use Exporter qw(import);
  1         2  
  1         42  
6 1     1   6 use Carp qw(croak);
  1         3  
  1         152  
7              
8             our @EXPORT = qw(
9             hook
10             );
11              
12             our $VERSION = '1.00';
13              
14             sub hook
15             {
16 3     3 1 145 my ($subname, $decorator) = @_;
17 3         7 my ($package) = caller;
18              
19 3         38 my $build_method = $package->can("build");
20 3 50       9 croak "Can't hook $subname: no build() method in $package"
21             unless defined $build_method;
22              
23 1     1   8 no strict 'refs';
  1         2  
  1         62  
24 1     1   15 no warnings 'redefine';
  1         2  
  1         247  
25              
26 3         10 *{"${package}::build"} = sub {
27 3     3   47831 my $self = shift;
28              
29 3         19 my $hooked_method = $package->can($subname);
30 3 100       211 croak "Trying to hook $subname, which doesn't exist"
31             unless defined $hooked_method;
32              
33 2         11 *{"${package}::$subname"} = sub {
34 2     2   21 my ($kelp, @args) = @_;
35              
36             return wantarray ?
37 2 50       11 $decorator->($hooked_method, $kelp, @args) :
38             scalar $decorator->($hooked_method, $kelp, @args);
39 2         8 };
40              
41             return wantarray ?
42 2 50       10 $self->$build_method(@_) :
43             scalar $self->$build_method(@_);
44 3         12 };
45 3         8 return;
46             }
47              
48              
49             1;
50             __END__
51              
52             =head1 NAME
53              
54             KelpX::Hooks - Override any method in your Kelp application
55              
56             =head1 SYNOPSIS
57              
58             # in your Kelp application
59             use KelpX::Hooks;
60              
61             # and then...
62             hook "template" => sub {
63             return "No templates for you!";
64             };
65              
66             =head1 DESCRIPTION
67              
68             This module allows you to override methods in your Kelp application class. The provided C<hook> method can be compared to Moose's C<around>, and it mimics its interface. The difference is in how and when the replacement of the actual method occurs.
69              
70             The problem here is that Kelp's modules are modifying the symbol table for the module at the runtime, which makes common attempts to change their methods` behavior futile. You can't override them, you can't change them with method modifiers, you can only replace them with different methods.
71              
72             This module fights the symbol table magic with more symbol table magic. It will replace any method with your anonymous subroutine after the application is built and all the modules have been loaded.
73              
74             =head2 EXPORT
75              
76             =head3 hook
77              
78             hook "sub_name" => sub {
79             my ($original_sub, $self, @arguments) = @_;
80              
81             # your code, preferably do this at some point:
82             return $self->$original_sub(@arguments);
83             };
84              
85             Allows you to provide your own subroutine in place of the one specified. The first argument is the subroutine that's being replaced. It won't be run at all unless you call it explicitly.
86              
87             Please note that Kelp::Less is not supported.
88              
89             =head1 SEE ALSO
90              
91             L<Kelp>, L<Moose::Manual::MethodModifiers>
92              
93             =head1 AUTHOR
94              
95             Bartosz Jarzyna, E<lt>brtastic.dev@gmail.comE<gt>
96              
97             =head1 COPYRIGHT AND LICENSE
98              
99             Copyright (C) 2020 by Bartosz Jarzyna
100              
101             This library is free software; you can redistribute it and/or modify
102             it under the same terms as Perl itself, either Perl version 5.10.1 or,
103             at your option, any later version of Perl 5 you may have available.
104              
105              
106             =cut