File Coverage

blib/lib/Dancer2/Core/Role/Hookable.pm
Criterion Covered Total %
statement 54 55 98.1
branch 17 20 85.0
condition 2 3 66.6
subroutine 12 12 100.0
pod 0 5 0.0
total 85 95 89.4


line stmt bran cond sub pod time code
1             package Dancer2::Core::Role::Hookable;
2             # ABSTRACT: Role for hookable objects
3             $Dancer2::Core::Role::Hookable::VERSION = '1.0.0';
4 157     157   185893 use Moo::Role;
  157         522  
  157         1027  
5 157     157   77723 use Dancer2::Core;
  157         460  
  157         4344  
6 157     157   5508 use Dancer2::Core::Types;
  157         468  
  157         1154  
7 157     157   1994396 use Carp 'croak';
  157         496  
  157         10251  
8 157     157   14092 use Safe::Isa;
  157         14087  
  157         152108  
9              
10             requires 'supported_hooks', 'hook_aliases';
11              
12             # The hooks registry
13             has hooks => (
14             is => 'ro',
15             isa => HashRef,
16             builder => '_build_hooks',
17             lazy => 1,
18             );
19              
20       884 0   sub BUILD { }
21              
22             # after a hookable object is built, we go over its postponed hooks and register
23             # them if any.
24             after BUILD => sub {
25             my ( $self, $args ) = @_;
26             $self->_add_postponed_hooks($args)
27             if defined $args->{postponed_hooks};
28             };
29              
30             sub _add_postponed_hooks {
31 806     806   2204 my ( $self, $args ) = @_;
32 806         1841 my $postponed_hooks = $args->{postponed_hooks};
33              
34             # find the internal name of the hooks, from the caller name
35 806         2202 my $caller = ref($self);
36 806         7496 my ( $dancer, $h_type, $h_name, @rest ) = map lc, split /::/, $caller;
37 806 50       3475 $h_name = $rest[0] if $h_name eq 'role';
38 806 100       6090 if ( $h_type =~ /(template|logger|serializer|session)/ ) {
39 606         1508 $h_name = $h_type;
40 606         1317 $h_type = 'engine';
41             }
42              
43             # keep only the hooks we want
44 806         2409 $postponed_hooks = $postponed_hooks->{$h_type}{$h_name};
45 806 100       17354 return unless defined $postponed_hooks;
46              
47 5         24 foreach my $name ( keys %{$postponed_hooks} ) {
  5         32  
48 5         20 my $hook = $postponed_hooks->{$name}{hook};
49 5         21 my $caller = $postponed_hooks->{$name}{caller};
50              
51             $self->has_hook($name)
52             or croak "$h_name $h_type does not support the hook `$name'. ("
53 5 50       20 . join( ", ", @{$caller} ) . ")";
  0         0  
54              
55 5         217 $self->add_hook($hook);
56             }
57             }
58              
59             # mst++ for the hint
60             sub _build_hooks {
61 368     368   5594 my ($self) = @_;
62 368         2055 my %hooks = map +( $_ => [] ), $self->supported_hooks;
63 368         7112 return \%hooks;
64             }
65              
66             # This binds a coderef to an installed hook if not already
67             # existing
68             sub add_hook {
69 329     329 0 10663 my ( $self, $hook ) = @_;
70 329         6339 my $name = $hook->name;
71 329         3491 my $code = $hook->code;
72              
73 329 100       1238 croak "Unsupported hook '$name'"
74             unless $self->has_hook($name);
75              
76 328         3898 push @{ $self->hooks->{$name} }, $code;
  328         5539  
77             }
78              
79             # allows the caller to replace the current list of hooks at the given position
80             # this is useful if the object where this role is composed wants to compile the
81             # hooks.
82             sub replace_hook {
83 1667     1667 0 4706 my ( $self, $position, $hooks ) = @_;
84              
85 1667 100       3345 croak "Hook '$position' must be installed first"
86             unless $self->has_hook($position);
87              
88 1666         36518 $self->hooks->{$position} = $hooks;
89             }
90              
91             # Boolean flag to tells if the hook is registered or not
92             sub has_hook {
93 26091     26091 0 45885 my ( $self, $hook_name ) = @_;
94 26091         416839 return exists $self->hooks->{$hook_name};
95             }
96              
97             # Execute the hook at the given position
98             sub execute_hook {
99 22164     22164 0 33634 my $self = shift;
100 22164         30172 my $name = shift;
101              
102 22164 100 66     75445 $name and !ref $name
103             or croak "execute_hook needs a hook name";
104              
105             $name = $self->hook_aliases->{$name}
106 22163 100       47318 if exists $self->hook_aliases->{$name};
107              
108 22163 50       49618 croak "Hook '$name' does not exist"
109             if !$self->has_hook($name);
110              
111 22163 100       192144 $self->$_isa('Dancer2::Core::App') &&
112             $self->log( core => "Entering hook $name" );
113              
114 22163         276103 for my $hook ( @{ $self->hooks->{$name} } ) {
  22163         347025  
115 637         6638 $hook->(@_);
116             }
117             }
118              
119             1;
120              
121             __END__
122              
123             =pod
124              
125             =encoding UTF-8
126              
127             =head1 NAME
128              
129             Dancer2::Core::Role::Hookable - Role for hookable objects
130              
131             =head1 VERSION
132              
133             version 1.0.0
134              
135             =head1 AUTHOR
136              
137             Dancer Core Developers
138              
139             =head1 COPYRIGHT AND LICENSE
140              
141             This software is copyright (c) 2023 by Alexis Sukrieh.
142              
143             This is free software; you can redistribute it and/or modify it under
144             the same terms as the Perl 5 programming language system itself.
145              
146             =cut