如何在 Perl API 中自省正则表达式答案

【问题标题】：How to introspect regexes in the Perl API如何在 Perl API 中自省正则表达式
【发布时间】：2012-08-04 18:50:21
【问题描述】：

我正在编写一些需要序列化 Perl 正则表达式的代码，包括任何正则表达式标志。仅支持标志的子集，因此我需要检测不支持的标志（如 /u）何时在正则表达式对象中。

当前版本的代码是这样做的：

static void serialize_regex_flags(buffer *buf, SV *sv) {
  char flags[] = {0,0,0,0,0,0};
  unsigned int i = 0, f = 0;
  STRLEN string_length;
  char *string = SvPV(sv, string_length);

然后手动处理string char-by-char 以查找标志。

这里的问题是正则表达式标志的字符串化从例如更改（我认为在 Perl 5.14 中） (?i-xsm:foo) 到 (?^i:foo)，这让解析很痛苦。

我可以检查perl 的版本，或者只是编写解析器来处理这两种情况，但有件事告诉我必须有一个更好的自省方法可用。

【问题讨论】：

标签： c regex perl introspection xs

【解决方案1】：

在 Perl 中，您将使用 re::regexp_pattern。

 my $re = qr/foo/i;
 my ($pat, $mods) = re::regexp_pattern($re);
 say $pat;   # foo
 say $mods;  # i

从regexp_pattern的来源可以看出，API中没有获取该信息的函数，所以我建议你也从XS调用该函数。

perlcall 涵盖了从 C 调用 Perl 函数。我想出了以下未经测试的代码：

/* Calls re::regexp_pattern to extract the pattern
 * and flags from a compiled regex.
 *
 * When re isn't a compiled regex, returns false,
 * and *pat_ptr and *flags_ptr are set to NULL.
 *
 * The caller must free() *pat_ptr and *flags_ptr.
 */

static int regexp_pattern(char ** pat_ptr, char ** flags_ptr, SV * re) {
   dSP;
   int count;
   ENTER;
   SAVETMPS;
   PUSHMARK(SP);
   XPUSHs(re);
   PUTBACK;
   count = call_pv("re::regexp_pattern", G_ARRAY);
   SPAGAIN;

   if (count == 2) {
      /* Pop last one first. */
      SV * flags_sv = POPs;
      SV * pat_sv   = POPs;

      /* XXX Assumes no NUL in pattern */
      char * pat   = SvPVutf8_nolen(pat_sv); 
      char * flags = SvPVutf8_nolen(flags_sv);

      *pat_ptr   = strdup(pat);
      *flags_ptr = strdup(flags);
   } else {
      *pat_ptr   = NULL;
      *flags_ptr = NULL;
   }

   PUTBACK;
   FREETMPS;
   LEAVE;

   return *pat_ptr != NULL;
}

用法：

SV * re = ...;

char * pat;
char * flags;
regexp_pattern(&pat, &flags, re);

【讨论】：

谢谢，@ikegami。以您的 C 代码为起点，我能够得到我需要的东西。需要注意的一点是，返回值必须以相反的顺序弹出（所以flags_sv 首先出现而不是第二次出现。）

【解决方案2】：

use Data::Dump::Streamer ':util';
my ($pattern, $flags) = regex( qr/foo/i );
print "pattern: $pattern, flags: $flags\n";
# pattern: foo, flags: i

但如果您尝试限制更新的功能，那么您要做的工作远不止检查 /u。

【讨论】：