engine/Hooks.pm

   1 package re::engine::Hooks;
   2
   3 use 5.010001;
   4
   5 use strict;
   6 use warnings;
   7
   8 =head1 NAME
   9
  10 re::engine::Hooks - Hookable variant of the Perl core regular expression engine.
  11
  12 =head1 VERSION
  13
  14 Version 0.03
  15
  16 =cut
  17
  18 our ($VERSION, @ISA);
  19
  20 sub dl_load_flags { 0x01 }
  21
  22 BEGIN {
  23  $VERSION = '0.03';
  24  require DynaLoader;
  25  push @ISA, qw<Regexp DynaLoader>;
  26  __PACKAGE__->bootstrap($VERSION);
  27 }
  28
  29 =head1 SYNOPSIS
  30
  31 In your XS file :
  32
  33     #include "re_engine_hooks.h"
  34
  35     STATIC void dri_comp_node_hook(pTHX_ regexp *rx, regnode *node) {
  36      ...
  37     }
  38
  39     STATIC void dri_exec_node_hook(pTHX_
  40        regexp *rx, regnode *node, regmatch_info *info, regmatch_state *state) {
  41      ...
  42     }
  43
  44     MODULE = Devel::Regexp::Instrument    PACKAGE = Devel::Regexp::Instrument
  45
  46     BOOT:
  47     {
  48      reh_config cfg;
  49      cfg.comp_node = dri_comp_node_hook;
  50      cfg.exec_node = dri_exec_node_hook;
  51      reh_register("Devel::Regexp::Instrument", &cfg);
  52     }
  53
  54 In your Perl module file :
  55
  56     package Devel::Regexp::Instrument;
  57
  58     use strict;
  59     use warnings;
  60
  61     our ($VERSION, @ISA);
  62
  63     use re::engine::Hooks; # Before loading our own shared library
  64
  65     BEGIN {
  66      $VERSION = '0.01';
  67      require DynaLoader;
  68      push @ISA, 'DynaLoader';
  69      __PACKAGE__->bootstrap($VERSION);
  70     }
  71
  72     sub import   { re::engine::Hooks::enable(__PACKAGE__) }
  73
  74     sub unimport { re::engine::Hooks::disable(__PACKAGE__) }
  75
  76     1;
  77
  78 In your F<Makefile.PL>
  79
  80     use ExtUtils::Depends;
  81
  82     my $ed = ExtUtils::Depends->new(
  83      'Devel::Regexp::Instrument' => 're::engine::Hooks',
  84     );
  85
  86     WriteMakefile(
  87      $ed->get_makefile_vars,
  88      ...
  89     );
  90
  91 =head1 DESCRIPTION
  92
  93 This module provides a version of the perl regexp engine that can call user-defined XS callbacks at the compilation and at the execution of each regexp node.
  94
  95 =head1 C API
  96
  97 The C API is made available through the F<re_engine_hooks.h> header file.
  98
  99 =head2 C<reh_comp_node_hook>
 100
 101 The typedef for the regexp node compilation phase hook.
 102 Currently evaluates to :
 103
 104     typedef void (*reh_comp_node_hook)(pTHX_ regexp *, regnode *);
 105
 106 =head2 C<reh_exec_node_hook>
 107
 108 The typedef for the regexp node_execution phase hook.
 109 Currently evaluates to :
 110
 111     typedef void (*reh_exec_node_hook)(pTHX_ regexp *, regnode *, regmatch_info *, regmatch_state *);
 112
 113 =head2 C<reh_config>
 114
 115 A typedef'd struct that holds a set of all the different callbacks publicized by this module.
 116 It has the following members :
 117
 118 =over 4
 119
 120 =item *
 121
 122 C<comp_node>
 123
 124 A function pointer of type C<reh_comp_node_hook> that will be called each time a regnode is compiled.
 125 Allowed to be C<NULL> if you don't want to call anything for this phase.
 126
 127 =item *
 128
 129 C<exec_node>
 130
 131 A function pointer of type C<reh_exec_node_hook> that will be called each time a regnode is executed.
 132 Allowed to be C<NULL> if you don't want to call anything for this phase.
 133
 134 =back
 135
 136 =head2 C<reh_register>
 137
 138     void reh_register(pTHX_ const char *key, reh_config *cfg);
 139
 140 Registers the callbacks specified by the C<reh_config *> object C<cfg> under the given name C<key>.
 141 C<cfg> can be a pointer to a static object of type C<reh_config>.
 142 C<key> is expected to be a nul-terminated string and should match the argument passed to L</enable> and L</disable> in Perl land.
 143 An exception will be thrown if C<key> has already been used to register callbacks.
 144
 145 =cut
 146
 147 my $RE_ENGINE = _ENGINE();
 148
 149 my $croak = sub {
 150  require Carp;
 151  Carp::croak(@_);
 152 };
 153
 154 =head1 PERL API
 155
 156 =head2 C<enable>
 157
 158     enable $key;
 159
 160 Lexically enables the hooks associated with the key C<$key>.
 161
 162 =head2 C<disable>
 163
 164     disable $key;
 165
 166 Lexically disables the hooks associated with the key C<$key>.
 167
 168 =cut
 169
 170 sub enable {
 171  my ($key) = @_;
 172
 173  s/^\s+//, s/\s+$// for $key;
 174  $croak->('Invalid key') if $key =~ /\s/ or not _registered($key);
 175  $croak->('Another regexp engine is in use') if  $^H{regcomp}
 176                                              and $^H{regcomp} != $RE_ENGINE;
 177
 178  $^H |= 0x020000;
 179
 180  my $hint = $^H{+(__PACKAGE__)} // '';
 181  $hint = "$key $hint";
 182  $^H{+(__PACKAGE__)} = $hint;
 183
 184  $^H{regcomp} = $RE_ENGINE;
 185
 186  return;
 187 }
 188
 189 sub disable {
 190  my ($key) = @_;
 191
 192  s/^\s+//, s/\s+$// for $key;
 193  $croak->('Invalid key') if $key =~ /\s/ or not _registered($key);
 194
 195  $^H |= 0x020000;
 196
 197  my @other_keys = grep !/^\Q$key\E$/, split /\s+/, $^H{+(__PACKAGE__)} // '';
 198  $^H{+(__PACKAGE__)} = join ' ', @other_keys, '';
 199
 200  delete $^H{regcomp} if $^H{regcomp} and $^{regcomp} == $RE_ENGINE
 201                                      and !@other_keys;
 202
 203  return;
 204 }
 205
 206 =head1 EXAMPLES
 207
 208 Please refer to the F<t/re-engine-Hooks-TestDist/> directory in the distribution.
 209 It implements a couple of simple examples.
 210
 211 =head1 DEPENDENCIES
 212
 213 L<perl> 5.10.1.
 214
 215 L<ExtUtils::Depends>.
 216
 217 =head1 SEE ALSO
 218
 219 L<perlreguts>.
 220
 221 =head1 AUTHOR
 222
 223 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 224
 225 You can contact me by mail or on C<irc.perl.org> (vincent).
 226
 227 =head1 BUGS
 228
 229 Please report any bugs or feature requests to C<bug-re-engine-hooks at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=re-engine-Hooks>.
 230 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 231
 232 =head1 SUPPORT
 233
 234 You can find documentation for this module with the perldoc command :
 235
 236     perldoc re::engine::Hooks
 237
 238 =head1 COPYRIGHT & LICENSE
 239
 240 Copyright 2012 Vincent Pit, all rights reserved.
 241
 242 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 243
 244 =cut
 245
 246 1;