sub ret_const_tag_open { my $tag = shift; return sub { push @open_tags, $tag; return "<$tag>"; }; } sub ret_escape_code { my $end_pat = shift; my $name = shift; return sub { my $t_ref = shift; if ($$t_ref =~ m=\G(.*?)$end_pat=gs) { return "
" . encode_entities($1) . "
"; } else { return show_err("Unmatched $name tag found"); } }; } sub ret_tag_close { my $tag = shift; return sub { my @searched; while (@open_tags) { my $open = pop(@open_tags); push @searched, $open; if ($open eq $tag) { # Close em! return join '', map "", @searched; } } # No you cannot close a tag you didn't open! @open_tags = reverse @searched; pos(${$_[0]}) = 0; return show_err("Unmatched close tag "); }; } sub ret_tag_open { # The general case my $tag = shift; my %is_attrib; ++$is_attrib{$_} foreach @_; return sub { my $t_ref = shift; my $text = "<$tag"; while ( $$t_ref =~ /\G(?: \s+ ([\w\d]+) # Value \s*=\s*( # = attribute: [^\s>"'][^\s>]* | # Unquoted "[^"]*" | # Double-quoted '[^']*' # Single-quoted ) | \s*> # End of tag )/gx ) { if ($1) { # Trying to match an attrib if ($is_attrib{ lc($1) }) { $text .= " $1=$2"; } else { pos($$t_ref) = 0; return show_err("Tag '$tag' cannot accept attribute '$1'"); } } else { # Ended text push @open_tags, $tag; return "$text>"; } } return show_err("Unended <$tag> detected"); }; } sub ret_tag_handlers { my %attribs = @_; my @out = (); foreach my $tag (keys %attribs) { if (@{$attribs{$tag}}) { push @out, "<$tag", ret_tag_open($tag, @{$attribs{$tag}}); } else { push @out, "<$tag>", ret_const_tag_open($tag); } push @out, "", ret_tag_close($tag); } return @out; } sub show_err { my $err = join '', @_; return "

$err

"; }