Plugin.pm

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