use strict; use warnings; use re 'eval'; my $str = < \s* (.+) ) \s* $ (?{ add_string($^N) }) /xm; my $tokens; my ($type, $name); my $block = qr/ # capture a type (?: (\w+) \s+ ) (?{ $type = $^N }) ( # capture an optional name, set $name to that (?{ $name = undef }) # first unset $name, in case this doesn't match ((?: (\w+) \s+ )(?{ $name = $^N }) )? ) \{ # if this starts to look like an element, push a new cell on the stack (?{ new_elem($type, $name) }) ( ( # this subpattern tries to capture a complete body, with the closing brace (??{ $tokens }) \} (?{ close_elem() }) # if we got here it means we have a full body, with tokens and a closing brace ) | ( # if we got here, then the body subpattern failed, and we must abort (?{ abort_elem() }) (?!) # this match always fails because it negates a match on anything, that always succeeds ) ) /xs; my $blocks = qr/($block \s*)+/xs; my $strings = qr/($string \s*)+?/xs; $tokens = qr/\s* ( $blocks | $strings ) \s*/xs; # tokens is either some strings, or some blocks my $doc = qr/^$tokens$/s; my @stack; new_elem("doc" => "root"); # create the root element $str =~ $doc; use Data::Dumper; warn Dumper(@stack); # should contain just the root element sub new_elem { my $elem = { type => $_[0], (defined($_[1]) ? (name => $_[1]) : ()), contains => [], }; if (@stack){ push @{ $stack[-1]{contains} }, $elem } push @stack, $elem; } sub abort_elem { pop @stack; pop @{ $stack[-1]{contains} }; } sub close_elem { pop @stack } sub add_string { push @{ $stack[-1]{contains} }, $_[0] }