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 Carp 'croak';\r
   6 use Scalar::Util 'weaken';\r
   7 use XSLoader ();\r
   8 \r
   9 our $VERSION = '0.01';\r
  10 \r
  11 XSLoader::load __PACKAGE__, $VERSION;\r
  12 \r
  13 my $RE_ENGINE_PLUGIN = get_engine_plugin();\r
  14 my $NULL = 0;\r
  15 \r
  16 # How many? Used to cheat %^H\r
  17 my $callback = 0;\r
  18 # Valid callbacks\r
  19 my @callback = qw(comp exec intuit checkstr free dupe);\r
  20 # Where we store our CODE refs\r
  21 my %callback;\r
  22 \r
  23 sub import\r
  24 {\r
  25     my ($pkg, %sub) = @_;\r
  26 \r
  27     #$sub{$_} = sub {}\r
  28 \r
  29     for (@callback) {\r
  30         next unless exists $sub{$_};\r
  31         my $cb = delete $sub{$_};\r
  32 \r
  33         # Convert "package::sub" to CODE if it isn't CODE already\r
  34         unless (ref $cb eq 'CODE') {\r
  35             no strict 'refs';\r
  36             $cb = *{$cb}{CODE};\r
  37         }\r
  38 \r
  39         # Whine if we don't get a CODE ref or a valid package::sub name\r
  40         croak "'$_' is not CODE and neither is the *{$cb}{CODE} fallback"\r
  41             unless ref $cb eq 'CODE';\r
  42 \r
  43         # Get an ID to use\r
  44         my $id = $callback ++;\r
  45 \r
  46         # Insert into our callback storage,\r
  47         $callback{$_}->{$id} = $cb;\r
  48 \r
  49         # Weaken it so we don't end up hanging on to something the\r
  50         # caller doesn't care about anymore\r
  51         #weaken($callback{$_}->{$id}); # EEK, too weak!\r
  52 \r
  53         # Instert into our cache with a key we can retrive later\r
  54         # knowing the ID in %^H and what callback we're getting\r
  55         my $key = callback_key($_);\r
  56         $^H{$key} = $id;\r
  57     }\r
  58 \r
  59     $^H{regcomp} = $RE_ENGINE_PLUGIN;\r
  60 }\r
  61 \r
  62 sub unimport\r
  63 {\r
  64     my ($pkg) = @_;\r
  65 \r
  66     # Delete the regcomp hook\r
  67     delete $^H{regcomp} if $^H{regcomp} == $RE_ENGINE_PLUGIN;\r
  68 }\r
  69 \r
  70 sub callback_key\r
  71 {\r
  72     my ($name) = @_;\r
  73 \r
  74     sprintf "rep_%s", $name;\r
  75 }\r
  76 \r
  77 # Minimal function to be called from the XS\r
  78 sub get_callback\r
  79 {\r
  80     my ($name) = @_; # 'comp', 'exec', ...\r
  81 \r
  82     my $key = callback_key($name);\r
  83     my $h = (caller(0))[10];\r
  84     my $id = $h->{$key};\r
  85 \r
  86     my $cb = defined $id ? $callback{$name}->{$id} : 0;\r
  87 \r
  88     return $cb;\r
  89 }\r
  90 \r
  91 1;\r