root/lang/perl/Class-Hookable/trunk/lib/Class/Hookable.pm @ 2423

Revision 2423, 20.0 kB (checked in by nyarla, 7 years ago)

lang/perl/Class-Hookable: I modified POD.

Line 
1package Class::Hookable;
2
3use strict;
4use warnings;
5
6use Carp ();
7use Scalar::Util();
8
9use vars qw( $VERSION );
10$VERSION = '0.03';
11
12sub new { bless {}, shift }
13
14sub hookable_stash {
15    my ( $self ) = @_;
16
17    if ( ref $self->{'Class::Hookable'} ne 'HASH' ) {
18        $self->{'Class::Hookable'} = {
19            hooks   => {},
20            methods => {},
21            filters => {},
22        };
23    }
24
25    return $self->{'Class::Hookable'};
26}
27
28
29sub hookable_context {
30    my $self = shift;
31
32    if ( @_ ) {
33        my $context = shift;
34        if ( ref($context) && ! Scalar::Util::blessed($context) ) {
35            Carp::croak "Argument is not blessed object or class name.";
36        }
37        $self->hookable_stash->{'context'} = $context;
38    }
39
40    return $self->hookable_stash->{'context'};
41}
42
43sub hookable_all_hooks {
44    my $self = shift;
45    return $self->hookable_stash->{'hooks'};
46}
47
48sub hookable_all_methods {
49    my $self = shift;
50    return $self->hookable_stash->{'methods'};
51}
52
53sub hookable_set_filter {
54    my ( $self, @filters ) = @_;
55
56    while ( my ( $method, $filter ) = splice @filters, 0, 2 ) {
57        Carp::croak "Invalid filter name. you can use [a-zA-Z_]"
58            if ( $method =~ m{[^a-zA-Z_]} );
59
60        Carp::croak "filter is not CODE reference."
61            if ( ref $filter ne 'CODE' );
62
63        $self->hookable_stash->{'filters'}->{$method} = $filter;
64    }
65
66}
67
68sub hookable_filter_prefix {
69    my $self = shift;
70
71    if ( @_ ) {
72        my $prefix = shift;
73        Carp::croak "Invalid filter prefix. you can use [a-zA-Z_]"
74            if ( $prefix =~ m{[^a-zA-Z_]} );
75        $self->hookable_stash->{'filter_prefix'} = $prefix;
76    }
77    else {
78        return $self->hookable_stash->{'filter_prefix'};
79    }
80}
81
82sub hookable_call_filter {
83    my ( $self, $name, @args ) = @_;
84
85    Carp::croak "Filter name is not specified."
86        if ( ! $name );
87
88    my $prefix = $self->hookable_filter_prefix
89              || 'hookable_filter';
90
91    my $filter   = $self->hookable_stash->{'filters'}->{$name};
92       $filter ||= $self->can("${prefix}_${name}");
93       $filter ||= sub { return 1 };
94
95    return $filter->( $self, $name, @args );
96}
97
98sub register_hook {
99    my ( $self, $plugin, @hooks ) = @_;
100
101    Carp::croak "Plugin object is not blessed object or class name"
102        if ( ref $plugin && ! Scalar::Util::blessed($plugin) );
103
104    while ( my ( $hook, $callback ) = splice @hooks, 0, 2 ) {
105        Carp::croak "Callback is not CODE reference."
106            if ( ref $callback ne 'CODE' );
107
108        my $action = {
109            plugin      => $plugin,
110            callback    => $callback,
111        };
112
113        if ( $self->hookable_call_filter( 'register_hook', $hook, $action ) ) {
114            $self->hookable_all_hooks->{$hook} = []
115                if ( ref $self->hookable_all_hooks->{$hook} ne 'ARRAY' );
116
117            push @{ $self->hookable_all_hooks->{$hook} }, $action;
118        }
119    }
120}
121
122sub register_method {
123    my ( $self, $plugin, @methods ) = @_;
124
125    Carp::croak "Plugin object is not blessed obejct or class name."
126        if ( ref $plugin && ! Scalar::Util::blessed($plugin) );
127
128    while ( my ( $method, $function ) = splice @methods, 0, 2 ) {
129        Carp::croak "Function is not CODE reference."
130            if ( ref $function ne 'CODE' );
131
132        my $action = {
133            plugin      => $plugin,
134            function    => $function,
135        };
136
137        if ( $self->hookable_call_filter( 'register_method', $method, $action ) ) {
138            $self->hookable_all_methods->{$method} = $action;
139        }
140    }
141}
142
143sub registered_hooks {
144    my $self = shift;
145
146    my @hooks;
147
148    if ( @_ > 0 ) {
149        my $object = shift;
150
151        if ( ref $object && ! Scalar::Util::blessed( $object ) ) {
152            Carp::croak "Argument is not blessed object or class name.";
153        }
154
155        my $is_class = ( ! ref $object ) ? 1 : 0 ;
156
157        for my $hook ( keys %{ $self->hookable_all_hooks } ) {
158            for my $action ( @{ $self->hookable_all_hooks->{$hook} } ) {
159                my $plugin = $action->{'plugin'};
160                my $class  = ref $plugin || $plugin;
161                if ( $is_class ) {
162                    push @hooks, $hook if ( $class eq $object );
163                }
164                else {
165                    push @hooks, $hook if ( $plugin eq $object );
166                }
167            }
168        }
169    }
170    else {
171        @hooks = keys %{ $self->hookable_all_hooks };
172    }
173
174    @hooks = sort { $a cmp $b } @hooks;
175    return @hooks;
176}
177
178sub registered_callbacks {
179    my ( $self, $hook ) = @_;
180
181    Carp::croak "Hook name is not specified." if ( ! defined $hook );
182
183    my $list = $self->hookable_all_hooks->{$hook};
184       $list ||= [];
185
186    return @{ $list };
187}
188
189sub registered_methods {
190    my $self    = shift;
191    my @methods = ();
192
193    if ( @_ > 0 ) {
194        my $object = shift;
195
196        if ( ref $object && ! Scalar::Util::blessed($object) ) {
197            Carp::croak "Argument is not blessed object or class name.";
198        }
199
200        my $is_class = ( ! ref $object ) ? 1 : 0 ;
201
202        for my $method ( keys %{ $self->hookable_all_methods } ) {
203            my $plugin  = $self->hookable_all_methods->{$method}->{'plugin'};
204            my $class   = ref $plugin || $plugin;
205            if ( $is_class ) {
206                push @methods, $method if ( $class eq $object );
207            }
208            else {
209                push @methods, $method if ( $plugin eq $object );
210            }
211        }
212    }
213    else {
214        @methods = keys %{ $self->hookable_all_methods };
215    }
216
217    @methods = sort { $a cmp $b } @methods;
218    return @methods;
219}
220
221sub registered_function {
222    my ( $self, $method ) = @_;
223
224    Carp::croak "Method name is not specified"
225        if ( ! $method );
226
227    my $action = $self->hookable_all_methods->{$method};
228
229    return if ( ! $action );
230    return $action;
231}
232
233sub delete_plugin {
234    my ( $self, $object, @hooks ) = @_;
235
236    if ( ref $object && ! Scalar::Util::blessed($object) ) {
237        Carp::croak "Argument is not blessed object or class name.";
238    }
239
240    my $is_class = ( ! ref $object ) ? 1  : 0 ;
241    @hooks = keys %{ $self->hookable_all_hooks } if ( @hooks == 0 );
242
243    for my $hook ( $self->registered_hooks( $object ) ) {
244        next if ( ! grep { $hook eq $_ } @hooks );
245
246        my @actions = ();
247        for my $action ( $self->registered_callbacks( $hook ) ) {
248            my $plugin  = $action->{'plugin'};
249            my $class   = ref $plugin || $plugin;
250            if ( $is_class ) {
251                push @actions, $action if ( $class ne $object );
252            }
253            else {
254                push @actions, $action if ( $plugin ne $object );
255            }
256        }
257
258        $self->hookable_all_hooks->{$hook} = \@actions;
259    }
260
261}
262
263sub delete_hook {
264    my ( $self, $hook, @plugins ) = @_;
265
266    Carp::croak "Hook is not specified." if ( ! defined $hook );
267
268    if ( @plugins == 0 ) {
269        $self->hookable_all_hooks->{$hook} = [];
270    }
271    else {
272        for my $plugin ( @plugins ) {
273            $self->delete_plugin( $plugin, $hook );
274        }
275    }
276}
277
278sub run_hook {
279    my ( $self, $hook, $args, $once, $callback ) = @_;
280
281    if ( defined $callback && ref $callback ne 'CODE' ) {
282        Carp::croak "callabck is not code reference.";
283    }
284   
285
286    my @results;
287
288    my $context = ( defined $self->hookable_context ) ? $self->hookable_context : $self ;
289
290    for my $action ( $self->registered_callbacks( $hook ) ) {
291        if ( $self->hookable_call_filter( 'run_hook', $hook, $args, $action ) ) {
292            my $plugin = $action->{'plugin'};
293            my $result = $action->{'callback'}->( $plugin, $context, $args );
294            $callback->( $result ) if ( $callback );
295            if ( $once ) {
296                return $result if ( defined $once );
297            }
298            else {
299                push @results, $result;
300            }
301        }
302    }
303
304    return if ( $once );
305    return @results;
306}
307
308sub run_hook_once {
309    my ( $self, $hook, $args, $callback ) = @_;
310    return $self->run_hook( $hook, $args, 1, $callback );
311}
312
3131;
314__END__
315
316=head1 NAME
317
318Class::Hookable - Base class for hook mechanism
319
320=head1 SYNOPSIS
321
322  package MyApp::Plugins;
323  use base qw( Class::Hookable );
324 
325  my $hook = MyApp::Plugins->new;
326 
327  $hook->register_hook(
328      $plugin,
329      'hook.name' => $plugin->can('callback'),
330  );
331 
332  $hook->run_hook('hook.name', $args);
333
334=head1 DESCRIPTION
335
336Class::Hookable is the base class for the hook mechanism.
337This module supports the hook mechanism like L<Plagger>.
338
339This module was made based on the hook mechanism of L<Plagger>.
340I thank Tatsuhiko Miyagawa and Plagger contributors.
341
342=head1 BASIC METHOD
343
344=head2 new
345
346  my $hook = Class::Hookalbe->new;
347
348This method is a constructor of Class::Hookable.
349Nothing but that is being done.
350
351=head1 REGISTER METOHDS
352
353=head2 register_hook
354
355  $hook->register_hook(
356      $plugin,
357      'hook.A' => $plugin->can('callbackA'),
358      'hook.B' => $plugin->can('callbackB'),
359  );
360
361This method registers a plugin object and callbacks which corresponds to hooks.
362
363The plugin object is specified as the first argument,
364and one after that is specified by the order of C<'hook' =E<gt> \&callabck>.
365
366Only when C<$hook-E<gt>hookable_call_filter( 'run_hook', $hook, $action )> has returned truth,
367the callback specified by this method is registered with a hook.
368
369Please see L<"hookable_call_filter"> about C<$hook-E<gt>hookable_call_filter>.
370
371B<Arguments of C<$hook-E<gt>hookable_call_filter>>:
372
373  $hook->hookable_call_filter( 'run_hook', $hook, $action );
374
375=over 3
376
377=item 'run_hook'
378
379C<'run_hook'> is filter name.
380
381=item $hook
382
383The hook name specified as the register_hook method.
384
385=item $action
386
387  my ( $plugin, $callback ) = @{ $action }{qw( plugin callback )};
388
389The hash reference including plugin and callback.
390
391=back
392
393=head2 register_method
394
395  $hook->register_method(
396      $plugin,
397      'method.A' => $plugin->can('methodA'),
398      'method.B' => $plugin->can('methodB'),
399  );
400
401This method registers a plugin and functions with the methods.
402
403The specification of arguments is same as L<"register_hook"> method.
404
405The method is different from B<hook> and only a set of plugin and function are kept about one method.
406When specifying the method name which exists already, the old method is replaced with the new method.
407
408Only when C<$hook-E<gt>hookable_call_filter( 'register_method', $method, $action )> has returned truth,
409this method registers a plugin and function.
410
411Please see L<"hookable_call_filter"> about C<$hook-E<gt>hookable_call_filter>.
412
413B<Arguments of C<$hook-E<gt>hookable_call_filter>>:
414
415=over 3
416
417=item C<'register_method'>
418
419C<'run_hook'> is filter name.
420
421=item C<$method>
422
423The method name specified as the register_method method.
424
425=item C<$action>
426
427  my ( $plugin, $function ) = @{ $action }{qw( plugin function )};
428
429The hash reference including plugin and function.
430
431=back
432
433=head1 CALL METHODS
434
435=head2 run_hook
436
437  $hook->run_hook( $hook, $args, $once, $callback );
438  my @results = $hook->run_hook('hook.name', \%args, undef, \&callback);
439  my $result  = $hook->run_hook('hook.name', \%args, 1, \&callback);
440
441This method calls callback of the registered plugin to hook by the registered order.
442Arguments are specified by the order of C<$hook>, C<$args>, C<$once> and C<$callback>.
443
444B<Arguments to run_hook method>:
445
446=over 4
447
448=item C<$hook>
449
450Designation of the hook with which a plugin was registered.
451This argument is indispensable.
452
453=item C<$args>
454
455The argument which passes it to callback.
456This argument is optional.
457
458=item C<$once>
459
460When this argument becomes true, this method finishes calling callback
461when the first return value has been received.
462
463This argument is optional.
464
465=item C<$callback>
466
467  my $callback = sub {
468      my ( $result ) = @_;
469      # some code
470  }
471
472This argument specifies code reference.
473
474When having received a return value from callback of the registered,
475the callback specified by this argument is called.
476
477A return value of callback of registered plugin is passed to an argument of this callback.
478
479=back
480
481B<Arguments of registered callback>:
482
483  sub callback {
484      my ( $plugin, $context, $args ) = @_;
485      # some code
486  }
487
488The argument by which it is passed to callback is C<$plugin>, C<$context>, C<$args>.
489
490=over 3
491
492=item C<$plugin>
493
494The plugin object which passed a plugin and callback to the register_hook method when registering.
495
496=item C<$context>
497
498The context object.
499
500When C<$hook-E<gt>hookable_context> is specified, the specified object is passed,
501and when it isn't so, object of Class::Hookable (or object of inherited Class::Hookable class) is passed.
502
503Please see L<"hookable_context"> about context object which can be specified in C<$hook-E<gt>hookable_context>.
504
505=item C<$args>
506
507the argument specified by the run_hook method.
508
509=back
510
511B<Arguments of C<$hook-E<gt>hookable_call_filter>>:
512
513  $hook->hookable_call_filter( 'run_hook', $hook, $args, $action );
514
515Only when C<$hook-E<gt>hookable_call_filter( 'run_hook', $hook, $args, $action )> has returned truth,
516this method calls callback.
517
518Please see L<"hookable_call_filter"> about C<$hook-E<gt>hookable_call_filter>.
519
520=over 4
521
522=item 'run_hook'
523
524C<'run_hook'> is filter name.
525
526=item C<$hook>
527
528The hook name specified by the run_hook method.
529
530=item C<$args>
531
532The argument specified by the run_hook method.
533
534=item C<$action>
535
536  my ( $plugin, $callback ) = @{ $action }{qw( plugin callback )};
537
538The hash reference including the plugin and the callback.
539
540=back
541
542=head2 run_hook_once
543
544  my $result = $hook->run_hook_once( $hook, $args, $callback );
545
546This method is an alias of C<$hook-E<gt>run_hook( $hook, $args, 1, \&callback )>.
547
548=head1 FILTER METHODS
549
550=head2 hookable_set_filter
551
552  $hook->hookable_set_filter(
553      register_hook => \&filterA
554      run_hook      => \&filterB,
555  );
556
557This method registers the filter of hook and method.
558
559Arguments are specified by the order of C<'name' =E<gt> \&filter>.
560The character which can be used for the filter name is C<[a-zA-Z_]>.
561
562When registering a homonymous filter of the filter registered already,
563a old filter is replaced with a new filter.
564
565Please see L<"hookable_call_filter"> about a calling of the filter.
566
567=head2 hookable_call_filter
568
569  my $bool = $hook->hookable_call_filter( $name => @args );
570
571This method calls a specified filter.
572
573A filter name is specified as the first argument
574and an argument to a filter is specified as an argument after that.
575
576B<Search of filter>:
577
578This method searches for a filter from several places.
579
580First, when a specified filter is specified by C<$hook-E<gt>hookable_set_filter> method,
581the filter is used.
582
583Next when C<$hook-E<gt>can("${prefix}_${filter_name}")> is defined,
584its method is used as a filter.
585
586C<${prefix}> is return value of $hook->hookable_filter_prefix,
587and C<${filter_name}> is the filter name specified as this method.
588
589When C<$hook-E<gt>hookble_filter_perfix> is not specified,
590C<${prefix}> will be C<'hookable_filter'>.
591
592Please see L<"hookable_filter_prefix"> about C<$hook-E<gt>hookable_filter_prefix>.
593
594When a filter wasn't found, this method uses the filter to which truth is just always returned.
595
596B<Arguments of filter>:
597
598  $hook->hookable_set_filter(
599      'run_hook' => sub {
600          my ( $hook, $filter, @args ) = @_;
601      },
602  );
603
604=over 3
605
606=item C<$hook>
607
608Instance of Class::Hookable (or the class inheriting to Class::Hookable).
609
610=item C<$filter>
611
612The filter name called in C<$hook-E<gt>hookable_call_filter>.
613
614=item C<@args>
615
616Arguments to the filter to which it was passed by C<$hook-E<gt>hookable_call_filter>.
617
618=back
619
620=head2 hookable_filter_prefix
621
622  $hook->hookable_filter_prefix('myfilter_prefix');
623
624This method is accessor of filter prefix;
625
626When finding filter in call_filer_method,
627prefix specified by this method is used.
628
629The character which can be used for the filter prefix is C<[a-zA-Z_]>.
630
631=head1 UTILITY METHODS
632
633=head2 registered_hooks
634
635  my @hooks = $hook->registered_hooks( $plugin );
636  my @hooks = $hook->registered_hooks( 'ClassName' );
637
638This method returns a registered hook name.
639
640When calling without arguments, all registered hook name is returned.
641
642And when specifying plugin obejct (or Class name) as an argument,
643the hook name with which a plugin is registered is returned.
644
645=head2 registered_callbacks
646
647  for my $action ( $hook->registered_callbacks('hook.name') ) {
648      my ( $plugin, $callback ) = @{ $action }{qw( plugin callback )};
649      # some code
650  }
651
652This method returns plugin and callback registered with a hook.
653
654Return value is a list of hash reference including plugin and callback.
655When there are no registered plugin and callback, this method returns empty list.
656
657=head2 registered_methods
658
659  my @methods = $hook->registered_methods( $plugin );
660  my @methods = $hook->registered_methods( 'ClassName' );
661
662This method returns a registered method names.
663
664When calling without arguments, all registered method name is returned.
665and When specifying plugin object (or class name) as an arguments,
666the method name with which a plugin is registered is returned.
667
668=head2 registered_function
669
670  my $action = $hook->registered_function('method.name');
671  my ( $plugin, $function ) = @{ $action }{qw( plugin function )};
672
673This method returns plugin and callback registered with a method.
674
675Return value is a hash reference including plugin and callback.
676When nothing is registered, no this methods are returned.
677
678=head2 delete_hook
679
680  $hook->delete_hook( 'hook.name' );
681  $hook->delete_hook( 'hook.name' => ( $pluginA, 'ClassName' ) );
682
683This method deletes a registered hook.
684
685Hook name is specified as the first argument,
686and plugin object or class name is specified as an argument after that.
687
688When specifying only a hook as an argument,
689all plugin registered with the hook are deleted.
690
691And when specifying a hook and plugin object (or class name) as arguments,
692specified plugins are deleted from a specified hook.
693
694=head2 delete_plugin
695
696  $hook->delete_plugin( $plugin );
697  $hook->delete_plugin( ClassName => qw( hook.A hook.B ) );
698
699This method deletes a registered plugin.
700
701A plugin object or class name is specified as the first argument,
702and some hook names is specified as an argument after that.
703
704When specifying only a plugin object (or class name) as an argument,
705a plugin is deleted from all hooks.
706
707And when specifying a plugin object (or class name) and hooks as arguments,
708a plugin is deleted from specified hooks.
709
710=head1 ACCESSOR METOHDS
711
712=head2 hookable_stash
713
714  my $data = $hook->hookable_stash;
715
716This method is stash in Class::Hookable.
717All variables Class::Hookable needs are put here.
718
719This method does not get arguments,
720and return hash reference includes all variables.
721
722=head2 hookable_context
723
724  # set
725  $hook->hookable_context( $context );
726  # get
727  my $context = $hook->hookable_context;
728
729This method is accessor of context object.
730
731blessed object or class name is specified as the context object.
732
733Context object specified by this method is passed as the second argument of
734the subroutine registered with hook and method.
735
736see also L<"run_hook">.
737
738=head2 hookable_all_hooks
739
740  my $hooks = $hook->hookable_all_hooks;
741
742This method is accessor to hash reference which keeps hooks.
743all method of Class::Hookable is accessing hooks through this method.
744
745=head1 hookable_all_methods
746
747  my $methods = $hook->hookable_all_methods;
748
749This method is accesor to hash reference which keeps methods.
750all method of Class::Hookable is accessing methods through this method.
751
752=head1 AUTHOR
753
754Original idea by Tatsuhiko Miyagawa L<http://search.cpan.org/~miyagawa> in L<Plagger>
755
756Code by Naoki Okamura (Nyarla) E<lt>thotep@nayrla.netE<gt>
757
758=head1 LICENSE
759
760This library is free software; you can redistribute it and/or modify
761it under the same terms as Perl itself.
762
763=cut
Note: See TracBrowser for help on using the browser.