File Coverage

blib/lib/KelpX/Hooks.pm
Criterion Covered Total %
statement 34 34 100.0
branch 7 8 87.5
condition n/a
subroutine 9 9 100.0
pod 1 1 100.0
total 51 52 98.0


line stmt bran cond sub pod time code
1             package KelpX::Hooks;
2              
3             our $VERSION = '1.01';
4              
5 2     2   282018 use strict;
  2         8  
  2         61  
6 2     2   11 use warnings;
  2         4  
  2         54  
7 2     2   10 use Exporter qw(import);
  2         3  
  2         55  
8 2     2   10 use Carp qw(croak);
  2         3  
  2         307  
9              
10             our @EXPORT = qw(
11             hook
12             );
13              
14             sub hook
15             {
16 6     6 1 1246 my ($subname, $decorator) = @_;
17 6         12 my $package = caller;
18              
19 6 100       281 croak "Hooking build() method is forbidden"
20             if $subname eq "build";
21              
22 5         49 my $build_method = $package->can("build");
23 5 100       127 croak "Can't hook $subname: no build() method in $package"
24             unless defined $build_method;
25              
26 2     2   15 no strict 'refs';
  2         4  
  2         89  
27 2     2   12 no warnings 'redefine';
  2         4  
  2         460  
28              
29 4         12 *{"${package}::build"} = sub {
30 4     4   49282 my ($self) = @_;
31              
32 4         20 my $hooked_method = $package->can($subname);
33 4 100       224 croak "Trying to hook $subname, which doesn't exist"
34             unless defined $hooked_method;
35              
36 3         12 *{"${package}::$subname"} = sub {
37 4     4   1943 my ($kelp, @args) = @_;
38              
39             return wantarray
40             ?
41 4 50       18 $decorator->($hooked_method, $kelp, @args)
42             :
43             scalar $decorator->($hooked_method, $kelp, @args);
44 3         12 };
45              
46 3         12 goto $build_method;
47 4         16 };
48 4         11 return;
49             }
50              
51             1;
52             __END__
53              
54             =head1 NAME
55              
56             KelpX::Hooks - Override any method in your Kelp application
57              
58             =head1 SYNOPSIS
59              
60             # in your Kelp application
61             use KelpX::Hooks;
62              
63             # and then...
64             hook "template" => sub {
65             return "No templates for you!";
66             };
67              
68             =head1 DESCRIPTION
69              
70             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.
71              
72             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.
73              
74             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.
75              
76             =head2 EXPORT
77              
78             =head3 hook
79              
80             hook "sub_name" => sub {
81             my ($original_sub, $self, @arguments) = @_;
82              
83             # your code, preferably do this at some point:
84             return $self->$original_sub(@arguments);
85             };
86              
87             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.
88              
89             Please note that Kelp::Less is not supported.
90              
91             =head1 CAVEATS
92              
93             This module works by replacing the build method in symbol tables. Because of this, you cannot hook the build method itself.
94              
95             =head1 SEE ALSO
96              
97             L<Kelp>, L<Moose::Manual::MethodModifiers>
98              
99             =head1 AUTHOR
100              
101             Bartosz Jarzyna, E<lt>brtastic.dev@gmail.comE<gt>
102              
103             =head1 COPYRIGHT AND LICENSE
104              
105             Copyright (C) 2020 by Bartosz Jarzyna
106              
107             This library is free software; you can redistribute it and/or modify
108             it under the same terms as Perl itself, either Perl version 5.10.1 or,
109             at your option, any later version of Perl 5 you may have available.
110              
111              
112             =cut