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