Hello, I am the HTML::Parser nazi. I go around commenting on other people's attempts to parse HTML, and I always yell at them for trying to do something that's very hard themselves, and tell them to use HTML::Parser.

I intended to do that here.

I tried to break tilly's code.

I failed.

Damn.

So while I still don't necessarily understand why one wouldn't use HTML::Parser, as far as I can see this is clean. Excellent stuff. I'm very impressed.

-dlc

HTML::Parser would actually be an awful fit for this problem. If you don't believe it, try to duplicate the functionality the code already has.

The problem is that the incoming document is not HTML. It is a document in some markup language, some of whose tags look like html, but which isn't really. I don't want to spend time worrying about "broken html" that I am going to just escape. I don't want to worry about valid html that I want to deny. I want to report custom errors. (Hey, why not instead of just denying pre-monks image tags, also give an error with a link to the FAQ?) And I want to include markup tags you won't find in HTML.

I did a literal escape above using [code] above. I submit that HTML::Parser would not help with that. OK, so that should be <code> for this site, but this site would want to implement a couple of escaped I didn't. For instance the following handler would be defined for this site for [ (assuming that $site_base was http://www.perlmonks.org/index.pl and hoping that I don't make any typos):

use URI::Escape qw(uri_escape);
sub {
  my $t_ref = shift;
  if ($$t_ref =~ /\G([^\|\]]+)(?:\|(\|[^\|\]]+))?\]/g) {
    my $node_ref = "$site_base?node=" . uri_escape($1);
    my $node_name = encode_entities($2 || $1);
    return qq(<a href="$node_ref">$node_name</a>);
  }
  else {
    return show_err("Incomplete node link?");
  }
}
[download]

And, of course, given $node_id there is probably a function get_node_name available. And we have that lastnode_id the site keeps track of. So we also need a handler for [:// to link by ID, and that would be generated by something like this:

sub ret_link_by_id {
  my $tracking = shift; # eg "&lastnode_id=23453"
  sub {
    my $t_ref = shift;
    if ($$t_ref =~ /\G([1-9]\d*)(?:\|([^\|\]]+))?\]/g) {
      my $node_id = $1;
      my $name = $2 || get_node_name($node_id);
      my $node_name = encode_entities($name);
      my $url = "$site_base?node_id=$node_id$tracking";
      return qq(<a href="$url">$node_name</a>);
    }
    else {
      return show_err("Incomplete node_id link?");
    }
  }
}
[download]

If this still looks to your eyes like a slightly hacked up html spec, let me show you a feature that I dearly wish that this site had. Stop and think about what the following handler for \ does:

sub {
  my $t_ref = shift;
  if ($$t_ref =~ /\G([&\[\]<>\\])/g) {
    return encode_entities($1);
  }
}
[download]

Do you see it? Consider what would happen to the following string:

You can link by URL like this:
<pre>
  \<a href="http://www.perlmonks.org/"\><a href=http://www.perlmonks.o
+rg/>Perl Monks</a>\</a\>
</pre>
[download]

Got it yet?

No more looking up those pesky escape codes! :-)

My apologies for using you as a foil, but you just let me illustrate Tom's point perfectly. All of the stuff I am saying is obvious to anyone who has played with functional techniques, but since you haven't you are simply unable to see the amazing potential inherent in this method of code organization. And I happen to know that you are not a bad programmer, but this was a blind spot for you.

Time to put down the pot, we aren't boiling now. This is a frying pan and I feel like an omelette. :-)

No, you're absolutely right that HTML::Parser in and of itself wouldn't do a good job for this specific problem. My point in posting was really twofold:
• Writing a parser like this is very very difficult to get right, and usually it's better to find an existing tool that's already been stress-tested. You got it right because you know what you're doing, but I doubt many others would be able to execute like that.
• Ovid's initial problem, which apparently was the seed for your post, was tailor-made for HTML::Parser.
As far as functional programming goes, I'm not a stranger (I just recently replaced Perl code to walk two trees and find differences with compiled ML because it was faster and more conceptually simple), and I certainly support seeing more functional Perl. I'm not necessarily convinced that functional techniques helped in this particular program that much; my claim is that it worked so well because of the strength of the programmer. However, I do appreciate the elegance of the solution. But I continue to submit that your average Perl programmer would botch this problem subtly, and it would make more sense for them to use some pre-rolled solution.

-dlc

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]

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]

Hello! Perhaps the following page will offer a shorter introduction into a functional programming in Perl.
http://pobox.com/~oleg/ftp/Scheme/Scheme-in-Perl.txt

The page shows off the fixpoint combinator, the fold combinator, closures, higher-order functions, and implementations of a a few algorithms on lists. It's noteworthy how easy it was to translate these algorithms from Scheme to Perl. Even the location of parentheses is sometimes similar to that in Scheme notation. The page finishes with examples of improper and circular lists.

As to parsing of XML in a pure functional style, a SSAX parser may serve as an example:
http://pobox.com/~oleg/ftp/Scheme/SSAX.scm

The parser fully supports XML namespaces, character and parsed entities, xml:space, CDATA sections, nested entities, attribute value normalization, etc. The parser offers support for XML validation, to a full or a partial degree. It does not use assignments at all. It could be used to parse HTML too.

edited: Fri Jan 31 15:23:34 2003 by jeffa - linkafied those URL's

For all you out there who now want to learn about functional programming (and the other styles, too) - do yourself a favor and work through this excellent book:

<cite>Structure and Interpretation of Computer Programs. Harold Abelson and Gerald Jay Sussman with Julie Sussman. The MIT Press, 1996. Second Edition.</cite>

This book has changed my programming world from ground up. Ok, agreed, it is "challenging", as they like to put it in some reviews. Don't mind. Go forward. Buy it. Read it. Study it. Do the exercises. It's simply the best single book on programming that I know, and the only book that I know that really captures a lot of the "Zen" of programming.

Update: This book is (incredibly) now available online. Thanks to the Arsdigita people! Great service to all programmers.

Christian Lemburg
Brainbench MVP for Perl
http://www.brainbench.com

This posting is long after the fact, but the URL mentioned above is not working for me. See http://mitpress.mit.edu/sicp/ for the new book home.

I have to agree with you that all programmers should try their hand at all the programming styles, even if it's just so they can experience the joy of functional programming first hand!

Cheers!

That is one of several small mistakes in the code. Another is that there is only one allowed font attribute and it makes no sense. Another is that the RE engine has a bit of behaviour that I didn't understand when I wrote the code, and so I need to somewhere insert pos($raw) = pos($raw);. I leave verification that this is not a no-op, plus discovery of how this can lead to a bug, to a close reading of perlre. An important one pointed out by nate is that in reality the post will appear inside of a layout which is itself done with tables. Various tags that start new parts of a table should only be allowed inside of a table that you start. Plus he pointed out that some HTML tags take attributes which do not follow the usual pattern, for instance checkboxes can be "checked".

For these reasons and more, I did a rewrite at Functional take 2 which should have somewhat fewer bugs. I long ago made the decision that (partly because this site does not keep revision histories) I wanted to leave the original as it was, flaws and all.