Plugin.pm

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