comment on

OK, this reimplementation is for nate. I really did start out thinking I was going to make the handler modal, but when I got done it just didn't make sense. For instance the hack to handle tables (which was really the reason for wanting it in the first place) would have resulted in a circular reference which is a memory leak.

What I did instead was added several hooks for pre and post filters. And made the final routine return a subroutine that processes markup. It would be possible to actually use this in a modal way, just set the pos() to the end of the string and then have the post hook set the pos() to whatever you wanted it to be. I did most of the work required, I just didn't think it made sense for the problem at hand.

For people other than nate, this change fixes a few minor bugs, can be used to handle the attribute "checked" (that ability is not shown here), can be used to allow additional validations of attribute values, and (very important) allows you to refuse to let new table tags to be opened outside of a table that you have opened.

First a module, MarkupHandler.pm. This does most of the "reasoning".

package MarkupHandler;
use Carp;
use HTML::Entities qw(encode_entities);
use Exporter;
@ISA = 'Exporter';
@EXPORT_OK = qw(
  ret_bal_tag_handlers ret_escape_code
  ret_ok_attr_val ret_scrubber
);
use strict;

use vars qw(@open_tags);

# Gets the value of a tag attribute
sub get_attr_val {
  my $t_ref = shift;
  if (
    $$t_ref =~ /
      \G\s*=\s*(
        [^\s>"'][^\s>]* |   # Unquoted
        "[^"]*"         |   # Double-quoted
        '[^']*'             # Single-quoted
      )
    /gx
  ) {
    return $1;
  }
  else {
    return ('', "no value found");
  }
}

sub ret_bal_tag_handlers {
  my @out = ();
  while (@_) {
    my $tag = shift;
    my $name = $tag;
    if (ref($tag)) {
      if (exists $tag->{name}) {
        $name = $tag->{name};
      }
      else {
        confess("Tags must have name attributes");
      }
    }
    else {
      $tag = {name => $name};
    }
    my $attribs = shift;
    if (@$attribs) {
       push @out, "<$name", ret_tag_open($name, @$attribs);
    }
    else {
      push @out, "<$name>", ret_const_tag_open($name);
    }
    # Rewrite handler?
    if (exists $tag->{pre}) {
      push @out, wrap_handler($tag->{pre}, pop(@out), '');
    }
    push @out, "</$name>", ret_tag_close($name);
    if (exists $tag->{post}) {
      push @out, wrap_handler('', pop(@out), $tag->{post});
    }
  }
  return @out;
}

# Many tags have no attributes allowed.  Handle
# them efficiently.
sub ret_const_tag_open {
  my $tag = shift;
  return sub {
    push @open_tags, $tag;
    return "<$tag>";
  };
}

# Returns the basic "literal escape" that you see for
# code.
sub ret_escape_code {
  my $end_pat = shift;
  my $name = shift;
  return (
    $name,
    sub {
      my $t_ref = shift;
      if ($$t_ref =~ m=\G(.*?)$end_pat=gs) {
        return "<pre>" . encode_entities($1) . "</pre>";
      }
      else {
        return show_err("Unmatched $name tag found");
      }
    }
  );
}

# Generate an attribute handler based on an "ok value" test.
# Note that quotes on the attribute will exist in the
# value passed to the ok test.
sub ret_ok_attr_val {
  my $ok_test = shift;
  wrap_handler(
    '', \&get_attr_val,
    sub {
      my $text = shift;
      if ($ok_test->($text)) {
        $text;
      }
      else {
        return ('', "Illegal val '$text'");
      }
    }
  );
}

# Pass a list of case/handler pairs, returns an anonymous
# sub that processes those pairs.
sub ret_scrubber {
  my %handler = @_;
  # Sanity check
  foreach my $case (keys %handler) {
    unless (UNIVERSAL::isa($handler{$case}, 'CODE')) {
      carp("Case '$case' dropped - handlers must be functions");
      delete $handler{$case};
    }
  }
  $handler{pre} ||= sub {return '';};
  $handler{post} ||= sub {
    return join '', map "</$_>", reverse @open_tags;
  };
  # Sorted in reverse so that '<br' comes *before* '<b'...
  my $re_str = join "|",
  map {quotemeta} reverse sort keys %handler;
  my $is_handled = qr/$re_str/i;

  return sub {
    my $t_ref = shift;
    my $scrubbed;
    local @open_tags;
    
    while ($$t_ref =~ /\G([\w ]*)/g) {
      $scrubbed .= $1;
      my $pos = pos($$t_ref);
      if ($$t_ref =~ /\G($is_handled)/g) {
        my ($chunk, @err) = $handler{ lc($1) }->($t_ref);
        if (@err) {
          pos($$t_ref) = 0;
          $scrubbed .= show_err(@err);
        }
        else {
          $scrubbed .= $chunk;
          # Obscure bug fix.  You cannot match 2 zero
          # length patterns in a row, this resets the
          # flag so you can.
          pos($$t_ref) = pos($$t_ref);
        }
      }
      unless (pos($$t_ref)) {
        if (length($$t_ref) == $pos) {
          # EXIT HERE #
          return $scrubbed . $handler{post}->($t_ref);
        }
        else {
          my $char = substr($$t_ref, $pos, 1);
          pos($$t_ref) = $pos + 1;
          $scrubbed .= encode_entities($char);
        }
      }
    }
    confess("I have no idea how I got here!");
  }
}

# Returns a sub that closes a tag
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 </$tag>");
  };
}

# The general open tag
sub ret_tag_open {
  my $tag = shift;
  my %attr_test;
  foreach (@_) {
    if (ref($_)) {
      foreach my $attrib (keys %$_) {
        $attr_test{lc($attrib)} = $_->{$attrib};
      }
    }
    else {
      $attr_test{lc($_)} = \&get_attr_val;
    }
  }
  
  return sub {
    my $t_ref = shift;
    my $text = "<$tag";
    while ($$t_ref =~ /\G(?:\s+(\w+)|\s*>)/g) {
      if (defined($1)) {
        my $attrib = lc($1);
        if (exists $attr_test{$attrib}) {
          my ($chunk, @err) = $attr_test{$attrib}->($t_ref);
          if (@err) {
            return show_err(
              "While processing '$attrib' in <$tag>:", @err
            );
          }
          else {
            $text .= " $attrib=$chunk";
          }
        }
        else {
          pos($$t_ref) = 0;
          return show_err(
            "Tag '$tag' cannot accept attribute '$attrib'"
          );
        }
      }
      else {
        $text .= ">";
        push @open_tags, $tag;
        return $text;
      }
    }
    return show_err("Unended <$tag> detected");
  };
}

sub show_err {
  if (wantarray()) {
    return ('', @_);
  }
  else {
    my $err = encode_entities(join ' ', grep length($_), @_);
    return "<h2><font color=red>$err</font></h2> ";
  }
}

sub wrap_handler {
  my $pre = shift() || sub {''};
  my $fn = shift();
  my $post = shift() || sub {@_};
  return sub {
    my $t_ref = shift;
    my ($text, @err) = $pre->($t_ref);
    if (@err) {
      return show_err($text, @err);
    }
    (my $chunk, @err) = $fn->($t_ref);
    @err ?
      show_err("$text$chunk", @err) :
      $post->("$text$chunk");
  };
}

1;
[download]

And then the test script that I used with it. (Some of the functionality in this script could definitely be moved to the handler.)

use strict;
use vars qw($table_depth);
$table_depth = 0;

use MarkupHandler qw(
   ret_bal_tag_handlers ret_escape_code ret_ok_attr_val ret_scrubber 
);

my $href_test = ret_ok_attr_val(
  sub {
    shift() =~ m-^'?"?(http://|ftp://|mailto:|#)-i;
  }
);

my @bal_tags = (
  a => [
    qw(name target),
    {'href' => $href_test}
  ],
  font => [qw(color size)],
  ol => ['type'],
  p => ['align'],
  {
    name => 'table',
    pre => sub {
      if (5 > $table_depth++) { 
        return '';
      }
      else {
        $table_depth--;
        return ('', "Exceeded maximum table depth\n");
      }
    },
    post => sub {
      if (0 > --$table_depth) {
        $table_depth = 0;
        return ("", "Table depth should not be below 0");
      }
      @_;
    },
  }, [qw(bgcolor border cellpadding cellspacing width)],
  in_table_tags(
    colgroup => [ qw(align span valign width) ],
    td => [qw(align bgcolor colspan height rowspan valign width)],
    tr => [qw(align valign width)],
  ),
  map {$_, []} qw(
    b big blockquote br dd dl dt em h1 h2 h3 h4 h5 h6 hr
    i li pre small strike strong sub sup tt u ul
  ),
);

my @handlers = (
  ret_bal_tag_handlers(@bal_tags),
  ret_escape_code(qr(\[/code\]), "[code]"),
);

my $scrubber = ret_scrubber(@handlers);
my $text = <<'EOT';
Hello world.  <<<foo>;
[code] This is <code>...see the <a href=whatever> being escaped?  [/co
+de]
<b>Hello world</ br></b>ub>
<a href="javascript://www.d<a href=http://yada>evil.com" name=happy>he
+llo world
<a href=http://yada>hello</a>
<tr><td>
<table><tr>
<table>
<table>
<table>
<table>
<table>
</table>
</table>
</table>
</table>
</table>

EOT
print $scrubber->(\$text);

sub in_table_tags {
  my @out;
  while (@_) {
    my $name = shift;
    push @out, { 
      name => $name,
      pre => sub {
        $table_depth ? '' : ('', "Cannot open <$name>, not in table");
      },
    }, shift();
  }
  return @out;
}
[download]

Also some of the other handlers that I had in this thread are likely to be of interest.

In reply to Functional take 2 by tilly
in thread Why I like functional programming by tilly

Are you posting in the right place? Check out Where do I post X? to know for sure.
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
Want more info? How to link or How to display code and escape characters are good places to start.


There's more than one way to do things
	PerlMonks