lib/re/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.01
  15
  16 =cut
  17
  18 our ($VERSION, @ISA);
  19
  20 sub dl_load_flags { 0x01 }
  21
  22 BEGIN {
  23  $VERSION = '0.01';
  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_hook(pTHX_ regexp *rx, regnode *node) {
  36      ...
  37     }
  38
  39     STATIC void dri_exec_hook(pTHX_ regexp *rx, regnode *node,
  40                               regmatch_info *info, regmatch_state *state) {
  41      ...
  42     }
  43
  44     MODULE = Devel::Regexp::Instrument    PACKAGE = Devel::Regexp::Instrument
  45
  46     BOOT:
  47     {
  48      reh_register("Devel::Regexp::Instrument", dri_comp_hook, dri_exec_hook);
  49     }
  50
  51 In your Perl module file :
  52
  53     package Devel::Regexp::Instrument;
  54
  55     use strict;
  56     use warnings;
  57
  58     our ($VERSION, @ISA);
  59
  60     use re::engine::Hooks; # Before loading our own shared library
  61
  62     BEGIN {
  63      $VERSION = '0.01';
  64      require DynaLoader;
  65      push @ISA, 'DynaLoader';
  66      __PACKAGE__->bootstrap($VERSION);
  67     }
  68
  69     sub import   { re::engine::Hooks::enable(__PACKAGE__) }
  70
  71     sub unimport { re::engine::Hooks::disable(__PACKAGE__) }
  72
  73     1;
  74
  75 In your F<Makefile.PL>
  76
  77     use ExtUtils::Depends;
  78
  79     my $ed = ExtUtils::Depends->new(
  80      'Devel::Regexp::Instrument' => 're::engine::Hooks',
  81     );
  82
  83     WriteMakefile(
  84      $ed->get_makefile_vars,
  85      ...
  86     );
  87
  88 =head1 DESCRIPTION
  89
  90 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.
  91
  92 =head1 C API
  93
  94 The C API is made available through the F<re_engine_hooks.h> header file.
  95
  96 =head2 C<reh_comp_hook>
  97
  98 The typedef for the regexp compilation phase hook.
  99 Currently evaluates to :
 100
 101     typedef void (*reh_comp_hook)(pTHX_ regexp *, regnode *);
 102
 103 =head2 C<reh_exec_hook>
 104
 105 The typedef for the regexp execution phase hook.
 106 Currently evaluates to :
 107
 108     typedef void (*reh_exec_hook)(pTHX_ regexp *, regnode *, regmatch_info *, regmatch_state *);
 109
 110 =head2 C<reh_register>
 111
 112     void reh_register(pTHX_ const char *key, reh_comp_hook comp, reh_exec_hook exec);
 113
 114 Registers under the given name C<key> a callback C<comp> that will run during the compilation phase and a callback C<exec> that will run during the execution phase.
 115 Null function pointers are allowed in case you don't want to hook one of the phases.
 116 C<key> should match with the argument passed to L</enable> and L</disable> in Perl land.
 117 An exception will be thrown if C<key> has already been used to register callbacks.
 118
 119 =cut
 120
 121 my $RE_ENGINE = _ENGINE();
 122
 123 my $croak = sub {
 124  require Carp;
 125  Carp::croak(@_);
 126 };
 127
 128 =head1 PERL API
 129
 130 =head2 C<enable>
 131
 132     enable $key;
 133
 134 Lexically enables the hooks associated with the key C<$key>
 135
 136 =head2 C<disable>
 137
 138     disable $key;
 139
 140 Lexically disables the hooks associated with the key C<$key>
 141
 142 =cut
 143
 144 sub enable {
 145  my ($key) = @_;
 146
 147  s/^\s+//, s/\s+$// for $key;
 148  $croak->('Invalid key') if $key =~ /\s/ or not _registered($key);
 149  $croak->('Another regexp engine is in use') if  $^H{regcomp}
 150                                              and $^H{regcomp} != $RE_ENGINE;
 151
 152  $^H |= 0x020000;
 153
 154  my $hint = $^H{+(__PACKAGE__)} // '';
 155  $hint = "$key $hint";
 156  $^H{+(__PACKAGE__)} = $hint;
 157
 158  $^H{regcomp} = $RE_ENGINE;
 159
 160  return;
 161 }
 162
 163 sub disable {
 164  my ($key) = @_;
 165
 166  s/^\s+//, s/\s+$// for $key;
 167  $croak->('Invalid key') if $key =~ /\s/ or not _registered($key);
 168
 169  $^H |= 0x020000;
 170
 171  my @other_keys = grep !/^\Q$key\E$/, split /\s+/, $^H{+(__PACKAGE__)} // '';
 172  $^H{+(__PACKAGE__)} = join ' ', @other_keys, '';
 173
 174  delete $^H{regcomp} if $^H{regcomp} and $^{regcomp} == $RE_ENGINE
 175                                      and !@other_keys;
 176
 177  return;
 178 }
 179
 180 =head1 EXAMPLES
 181
 182 See the F<t/re-engine-Hooks-TestDist/> directory in the distribution.
 183 It implements a couple of simple examples.
 184
 185 =head1 DEPENDENCIES
 186
 187 L<perl> 5.10.1.
 188
 189 L<ExtUtils::Depends>.
 190
 191 =head1 SEE ALSO
 192
 193 L<perlreguts>.
 194
 195 =head1 AUTHOR
 196
 197 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 198
 199 You can contact me by mail or on C<irc.perl.org> (vincent).
 200
 201 =head1 BUGS
 202
 203 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>.
 204 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 205
 206 =head1 SUPPORT
 207
 208 You can find documentation for this module with the perldoc command :
 209
 210     perldoc re::engine::Hooks
 211
 212 =head1 COPYRIGHT & LICENSE
 213
 214 Copyright 2012 Vincent Pit, all rights reserved.
 215
 216 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 217
 218 =cut
 219
 220 1;