Plugin.pm

   1 # See Plugin.pod for documentation
   2 package re::engine::Plugin;
   3 use 5.009005;
   4 use strict;
   5
   6 our ($VERSION, @ISA);
   7
   8 BEGIN {
   9  $VERSION = '0.07';
  10  # All engines should subclass the core Regexp package
  11  @ISA = 'Regexp';
  12  require XSLoader;
  13  XSLoader::load(__PACKAGE__, $VERSION);
  14 }
  15
  16 my $RE_ENGINE_PLUGIN = ENGINE();
  17
  18 # How many? Used to cheat %^H
  19 my $callback = 1;
  20
  21 # Where we store our CODE refs
  22 my %callback;
  23
  24 # Generate a key to use in the %^H hash from a string, prefix the
  25 # package name like L<pragma> does
  26 my $key = sub { __PACKAGE__ . "::" . $_[0] };
  27
  28 sub import
  29 {
  30     my ($pkg, %sub) = @_;
  31
  32     # Valid callbacks
  33     my @callback = qw(comp exec);
  34
  35     for (@callback) {
  36         next unless exists $sub{$_};
  37         my $cb = delete $sub{$_};
  38
  39         unless (ref $cb eq 'CODE') {
  40             require Carp;
  41             Carp::croak("'$_' is not CODE");
  42         }
  43
  44         # Get an ID to use
  45         my $id = $callback ++;
  46
  47         # Insert into our callback storage,
  48         $callback{$_}->{$id} = $cb;
  49
  50         # Instert into our cache with a key we can retrive later
  51         # knowing the ID in %^H and what callback we're getting
  52         $^H{ $key->($_) } = $id;
  53     }
  54
  55     $^H{regcomp} = $RE_ENGINE_PLUGIN;
  56 }
  57
  58 sub unimport
  59 {
  60     # Delete the regcomp hook
  61     delete $^H{regcomp}
  62         if $^H{regcomp} == $RE_ENGINE_PLUGIN;
  63 }
  64
  65 # Minimal function to get CODE for a given key to be called by the
  66 # get_H_callback C function.
  67 sub _get_callback
  68 {
  69     my ($name) = @_; # 'comp', 'exec', ...
  70
  71     my $h = (caller(0))[10];
  72     my $id = $h->{ $key->($name) };
  73
  74     my $cb = defined $id ? $callback{$name}->{$id} : 0;
  75
  76     return $cb;
  77 }
  78
  79 sub num_captures
  80 {
  81     my ($re, %callback) = @_;
  82
  83     for my $key (keys %callback) {
  84         $key =~ y/a-z/A-Z/; # ASCII uc
  85         my $name = '_num_capture_buff_' . $key;
  86         $re->$name( $callback{$key} );
  87     }
  88 }
  89
  90 1;