Plugin.pm

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