[Perl]捕获平衡组(配对括号、多层镶嵌)结构化的歪招

523066680 · 发表于 2026-3-25 22:03:53

本帖最后由 523066680 于 2026-3-26 09:21 编辑

我看到之前论坛有不少相关的帖子和讨论。但是本人没有参与，主要是自己几乎没有遇到类似需求。
不过最近遇到了 :-)

首先考虑偷懒的做法，比如交给 DOM 解析器处理

# 523066680@163.com
use Modern::Perl;
use Mojo::DOM;
STDOUT->autoflush(1);
my $text =<<CODE;
lv0:
line1 (lv1:a (lv2:test(lv3:part1(lv4:deep)),turn(lv3:part2)) string);
line2 (lv1:b (lv2:I) (lv2:II));
CODE
# 把括号转成标签，标签名自定
$text =~ s/\(/<b>/g;
$text =~ s/\)/<\/b>/g;
# 交给 DOM 解析器
my $dom = Mojo::DOM->new->xml(1)->parse( $text );
print_st($dom, 0);
sub print_st
{
my ( $node, $lv ) = @_;
for my $e ( $node->children->each() )
{
my $s = $e;
# 还原括号
$s =~ s/<b>/\(/g;
$s =~ s/<\/b>/\)/g;
printf "%s%s\n", " "x$lv, $s;
print_st( $e, $lv+1 );
}
}

复制代码

输出结果：

(lv1:a (lv2:test(lv3:part1(lv4:deep)),turn(lv3:part2)) string)
(lv2:test(lv3:part1(lv4:deep)),turn(lv3:part2))
(lv3:part1(lv4:deep))
(lv4:deep)
(lv3:part2)
(lv1:b (lv2:I) (lv2:II))
(lv2:I)
(lv2:II)

复制代码

性能差了点，耗时 600ms，不过比起写正则应该节省了不少调试的时间。

zzz19760225 · 发表于 2026-4-3 15:51:32

本帖最后由 523066680 于 2026-4-3 17:13 编辑

请问版主，选择圆括号作为字符处理对象，而不是大括号{}或尖括号<>，有什么原因吗？

523066680 · 发表于 2026-3-25 22:49:14

搞完野路子了，看看有没有正道。相信这种问题肯定有成熟的模块，AI 推的第一个模块：
Text::Balanced - Extract delimited text sequences from strings.

先看第一个极简示例

use Text::Balanced qw(extract_bracketed);
my $text = "(inside(lv2:(lv3:deep)))right";
my ($extracted, $remainder) = extract_bracketed($text, '()');
printf "%s\n", $extracted;
printf "%s\n", $remainder;

复制代码

结果

(inside(lv2:(lv3:deep)))
right

复制代码

这个extract_bracketed 只负责提取从(括号起到右侧配对的)括号范围的内容，它不会返回带层次的结构体。
如果左侧带有其他字符例如 "abc(括号内的)..." 那么需要手动去掉左侧内容或者提取从左括号( 开始的子串交给 extract_bracketed 处理
接着让ai写了一个递归的版本，像剥洋葱一样处理

#!/usr/bin/env perl
use strict;
use warnings;
use Text::Balanced qw(extract_bracketed);
my $text = "left (inside(lv2:(lv3:deep))) def(inside2(lv2:(lv3:deep1)(lv3:deep2))) right";
print "orig: $text\n";
print "-" x 50 . "\n";
# 第一步：处理顶层的所有独立括号组
# 因为字符串开头可能不是括号，或者中间有 "def" 隔开，我们需要循环查找
process_level($text, 0);
sub process_level
{
my ($str, $level) = @_;
# 缩进显示
my $indent = " " x $level;
# 只要字符串里还有左括号，就继续尝试提取
while ($str =~ /\(/)
{
# 找到第一个左括号的位置，截取子串供 extract_bracketed 使用
# 因为 extract_bracketed 必须从字符串开头就是括号才能工作
my $start_pos = index($str, '(');
my $substring = substr($str, $start_pos);
# 执行提取
my ($extracted, $remainder) = extract_bracketed($substring, '()');
if (defined $extracted)
{
# 1. 打印当前层级的完整括号内容
print "${indent}Lv$level: $extracted\n";
# 2. 准备下一层级的数据：去掉最外层的括号
# 提取的内容格式是 "(...)", 我们取中间部分 [1 .. length-2]
my $inner_content = substr($extracted, 1, -1);
# 3. 递归处理内部内容（进入下一层）
process_level($inner_content, $level + 1);
# 4. 更新 $str，跳过刚才处理过的这部分，继续寻找同级的下一个括号
# 原字符串 = (括号前的垃圾) + (提取的部分) + (剩余部分)
# 我们需要保留：(括号前的垃圾) + (extract_bracketed 返回的 remainder)
# 注意：$substring 是从 $start_pos 开始的，所以 $start_pos 之前的部分要拼回去
my $prefix = substr($str, 0, $start_pos);
$str = $prefix . $remainder;
}
else
{
# 理论上如果 =~ /\(/ 成立，extract_bracketed 应该能提取到，除非括号不匹配
warn "检测到左括号但无法提取完整结构，可能存在语法错误。\n";
last;
}
}
}

复制代码

打印结果

orig: left (inside(lv2:(lv3:deep))) def(inside2(lv2:(lv3:deep1)(lv3:deep2))) right
--------------------------------------------------
Lv0: (inside(lv2:(lv3:deep)))
Lv1: (lv2:(lv3:deep))
Lv2: (lv3:deep)
Lv0: (inside2(lv2:(lv3:deep1)(lv3:deep2)))
Lv1: (lv2:(lv3:deep1)(lv3:deep2))
Lv2: (lv3:deep1)
Lv2: (lv3:deep2)

复制代码

耗时 200 ms

523066680 · 发表于 2026-3-26 17:08:39

这些模块太强大了！还要啥自行车…… 直接用。

#!/usr/bin/env perl
use strict;
use warnings;
use Text::Delimited::Marpa ':constants';
my($parser) = Text::Delimited::Marpa -> new
(
open => '<:',
close => ':>',
options => print_errors | print_warnings | mismatch_is_fatal,
);
my($text) = q|a <:b <:c:> d:> e <:f <: g <:h:> i:> j:> k|;
my($span) = 0;
my($result);
print ' | ';
printf '%10d', $_ for (1 .. 9);
print "\n";
print ' |';
print '0123456789' for (0 .. 8);
print "0\n";
print "Parsing |$text|. \n";
print "Span Start End Length Text\n";
if ($parser -> parse(text => \$text) == 0)
{
my($attributes);
my($indent);
my($text);
for my $node ($parser -> tree -> traverse)
{
next if ($node -> is_root);
$span++;
$attributes = $node -> meta;
$text = $$attributes{text};
$indent = $node -> depth - 1;
print sprintf("%4d %5d %3d %6d %-s\n", $span, $$attributes{start}, $$attributes{end}, $$attributes{length}, ' ' x $indent . "|$text|") if (length($text) );
}
}

复制代码

输出结果

| 1 2 3 4 5 6 7 8 9
|0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
Parsing |a <:b <:c:> d:> e <:f <: g <:h:> i:> j:> k|.
Span Start End Length Text
1 4 12 9 |b <:c:> d|
2 8 8 1 |c|
3 20 37 18 |f <: g <:h:> i:> j|
4 24 33 10 | g <:h:> i|
5 29 29 1 |h|

复制代码

523066680 · 发表于 2026-3-31 22:22:49

本帖最后由 523066680 于 2026-4-2 08:27 编辑

相关帖子求助PowerShell平衡组取所有匹配项
chatgpt写的PowerShell正则平衡组示例改错

因为最早接触的是批处理，所以涉及字符串处理的时候，总会想起效率并不那么高的 "占位符" 方案，
这个方法虽然效率不高，但是非常省心，不会用到很深的正则知识。
（在某些容易混淆的敏感情况，占位符可以制造"物理隔离"）

use Modern::Perl;
STDOUT->autoflush(1);
my $text = 'win s(dows s(" s(abc) ") )); s()';
my $list = [];
while ( $text =~ s/(s$[^\($]*\))/push @$list, $1; prn($1, $list); "\xfa". $#$list ."\xfb"; /e ) {}
sub prn
{
my ( $s, $list ) = @_;
while ($s =~ s/\xfa(\d+)\xfb/$list->[$1]/e) {};
say $s;
}

复制代码

打印结果

s(abc)
s(" s(abc) ")
s(dows s(" s(abc) ") )
s()

复制代码

这个案例中的右括号其实多了一个，可以在完成替换的时候做检测
printf "%s\n", $text if $text =~ /[]/;

523066680 · 发表于 2026-3-31 22:50:31

本帖最后由 523066680 于 2026-4-1 11:05 编辑

如果括号范围内出现带斜杠转义的括号
例如

'win (dows (" $ (abc) ()") $ \) )); ()';

复制代码

依旧是 "占位符" 方案

{
my $text = 'win (dows (" $ (abc) ()") $ \) )); ()';
my $list = [];
my $cmap = {
'$' => "\xba", '$' => "\xbb",
"\xba" => '$', "\xbb" => '$',
};
$text =~ s/\\[]/$cmap->{$&}/eg;
while ( $text =~ s/($[^\($]*\))/push @$list, $1; prn($1, $list, $cmap); "\xfa". $#$list ."\xfb"; /e ) {}
printf "Found unmatched parentheses\n" if $text =~ /[]/;
}
sub prn
{
my ( $s, $list, $cmap ) = @_;
while ($s =~ s/\xfa(\d+)\xfb/$list->[$1]/e) {};
$s =~ s/[\xba\xbb]/$cmap->{$&}/eg;
say $s;
}

复制代码

输出结果：

(abc)
()
(" \( (abc) ()")
(dows (" $ (abc) ()") $ \) )
()
Found unmatched parentheses

复制代码

然后我又回去看了看 Text::Balanced 的方案，默认支持括号内存在 $ 和 $ 的情况，然而转义括号也可能出现在常规括号之外，解决方法：在匹配括号起点时规避下 \( 即可
二楼的递归代码，while ($str =~ /\(/) 以及定位的部分改为：

while ($str =~ /(?<!\\)\(/)
{
my $start_pos = $-[0];

复制代码

测试文本以及结果：

orig: left (inside(lv2:(lv3:deep))) $ def(inside2(lv2:(lv3:deep1)(lv3:deep2 $ ))) right \)
--------------------------------------------------
Lv0: (inside(lv2:(lv3:deep)))
Lv1: (lv2:(lv3:deep))
Lv2: (lv3:deep)
Lv0: (inside2(lv2:(lv3:deep1)(lv3:deep2 \) )))
Lv1: (lv2:(lv3:deep1)(lv3:deep2 \) ))
Lv2: (lv3:deep1)
Lv2: (lv3:deep2 \) )

复制代码

523066680 · 发表于 2026-4-3 17:28:27

本帖最后由 523066680 于 2026-4-3 17:36 编辑

zzz19760225 发表于 2026-4-3 15:51
请问版主，选择圆括号作为字符处理对象，而不是大括号{}或尖括号，有什么原因吗？
...

这不是随便换吗有啥问题

		自动登录	找回密码
密码			注册

[新手上路]批处理新手入门导读	[视频教程]批处理基础视频教程	[视频教程]VBS基础视频教程	[批处理精品]批处理版照片整理器
[批处理精品]纯批处理备份&还原驱动	[批处理精品]CMD命令50条不能说的秘密	[在线下载]第三方命令行工具	[在线帮助]VBScript / JScript 在线参考

[原创教程] [Perl]捕获平衡组(配对括号、多层镶嵌)结构化的歪招

评分

使用 "占位符" 方案

如果括号范围内出现带斜杠转义的括号？

评分

浏览过的版块