I know that I posted this years ago, and other bugs in the post are not being fixed, but this one is a big one. When I wrote the node I didn't realize that the term
was already in use for something different than what I describe below. As a result I seem to have introduced a bad meme into the Perl world. Read on, but do understand that what I describe as functional programming isn't quite what is normally meant by the term...
One of my favorite quotes of all time on programming comes
from Tom Christiansen:
Absolutely. Perl does the first three very naturally,
but most Perl programmers only encounter imperative and
objective programming. Many never even encounter
objective, though that is not a problem for many here.
However I am a fan of functional programming. I mention
this from time to time but say that it takes a real code
example to show what I mean. Well I decided to take my
answer at RE (tilly) 1: Regexes vs. Maintainability to Big, bad, ugly regex problem and turn it into
a real problem. What I chose to do is implement
essentially the check specified at
Perl Monks Approved HTML tags, with an escape mode,
checks to make sure tags balance, and some basic error
reporting when it looks like people were trying to do
stuff but it isn't quite right.
If you have ever wondered what possible use someone
could find for anonymous functions, closures, and that
kind of thing, here is your chance to find out.
For those who do not know what Tom was talking about, here
are some quick definitions:
- Imperative programming is when you spend your
time telling the computer what to do.
- Functional programming, build some functions,
put them together into bigger ones, when you are done
run your masterpiece and call it a day.
- Objective programming access properties of
things and tell them to accomplish tasks for you without
caring what happens under the hood.
- Logical programming starts with a series of
rules and actions. When no more rules require acting on,
you are done.
We encounter two of these a lot in Perl. Imperative
programming is just plain old procedural. It is what most
of us do most of the time. Its biggest benefit is that it
is close to what the computer does and how we think. Also
we see a lot of objective programming - that is usually
called Object-Oriented Programming. It offers a layer of
abstraction between what you want done and how it is done.
This hides details and makes the end code easier to
maintain. In the long run it also
has benefits in terms of code-reuse.
We don't encounter the other two as often. Logical
programming is familiar to some here from writing makefiles.
The win is that you can handle very complex sets of
dependencies without having to stop and think about what
exactly will happen. Since that is exactly the kind of
problem that make try to solve, it is a good
fit there.
The most famous representative of functional programming is
Lisp. Functional programming offers similar benefits to
object-oriented programming. Where they differ for me is
that it lets you think about problems differently, and I
frequently find that I can very easily get all of my
configuration information into one place.
What follows is fairly complex, so I will present it in
pieces. If you have not seen functional programming this
will likely feel uncomfortable to read. I certainly found
the first examples I dealt with to be frustrating since I
could not figure out where anything happened. But
just remember that virtually everything here is just
setting up functions for later use, skip to the end if you
need to, and you should be fine.
Basic sanity
Import stuff, be careful, etc.
use strict;
use vars qw(@open_tags %handlers %bal_tag_attribs);
use HTML::Entities qw(encode_entities);
use Carp;
Configuration information
This has the configuration rules for all of the special
stuff we will allow. Tags and attributes, characters
that matter to html that we will let pass through, and
the [code] escape sequence. Note that I did
not use <code> because I wanted this to be easy to
post.
For a real site you might want several of these with
different rules for what is allowed depending on the
section and the user.
# This covers the majority of rules
%bal_tag_attribs = (
# Tags with ok attributes
a => [qw(href name target)],
# I added this one, and there is a <col> later as well
colgroup => [
qw(align span valign width)
],
font => ["color size"],
ol => ["type"],
# Balancing <p> looks strange but align needs closing
p => ["align"],
table => [
qw(bgcolor border cellpadding cellspacing width)
],
td => [
qw(align bgcolor colspan height rowspan valign width)
],
tr => [qw(align valign width)],
# Ones without attributes
# I omitted the 'nbsp' tag, should that be 'nobr'?
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
),
);
# Initialize default handlers
%handlers = (
# literal text with special meanings we allow
( map {my $tag = $_; ($tag, sub {return $tag})} qw(& <br> <col>) ),
# Various html tags
&ret_tag_handlers(%bal_tag_attribs),
# And our escape mode.
'[code]' => ret_escape_code(qr(\[/code\]), "[code]"),
);
Implementation of the handlers
This is the most complicated section by far. This sets up
functions for all of the tasks we will want done. If you
were to rewrite this program in a procedural fashion, you
would find that the logic in this section either would be
repeated many, many times, or else you would get into a lot
of very complex case statements.
That we don't need to do that shows code reuse in action!
A complex site would probably need more in this section
(for instance the linking logic we use), but when all is
said and done, not much.
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 "<pre>" . encode_entities($1) . "</pre>";
}
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 </$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, "</$tag>", ret_tag_close($tag);
}
return @out;
}
sub show_err {
my $err = join '', @_;
return "<h2><font color=red>$err</font></h2> ";
}
The actual function you call
Note that the documentation of and in the function
is as long as the function itself. However this is
naturally polymorphic. Even for a very complex site,
you likely wouldn't need to touch this function.
In fact you can understand pretty much everything
right here. You can add a lot of functionality
without getting in the way of your picture of how it
all works!
=head1 B<scrub_input()>
my $scrubbed_text = scrub_input($raw_text, [$handlers]);
This takes a string and an optional ref to a hash of handlers,
and returns html-escaped output, except for the sections handled
by the handlers which do whatever they want.
If handlers are passed their names should be lower case and start
with a character matching [^\w\s\d] or else they will not be
matched properly. While parsing the string, when they can be
matched case insensitively, then the handler is called. It will be
passed a reference to $raw_text right after that matches the name
of the handler. (pos($raw_text) will point to the end of the
name.) It should return the text to be inserted into the output,
and set pos($raw_text) to where to continue parsing from, or 0 if
no text was handled.
Two special handlers that may be used are "pre" and "post" that
will be called before and after (respectively) the raw text is
processed. For consistency they also get a reference to the raw
text.
If no handler is passed, it will use \%handlers instead.
=cut
sub scrub_input {
my $raw = shift;
local @open_tags;
my $handler = shift || \%handlers;
$handler->{pre} ||= sub {return '';};
$handler->{post} ||= sub {
return join '', map "</$_>", reverse @open_tags;
};
my $scrubbed = $handler->{pre}->(\$raw);
# This would be faster with the trie code from node 30896. But
# that is not the point of this example so I have not done that.
# Also note the next line is meant to force an NFA engine to
# match the longest alternative first
my $re_str = join "|",
map {quotemeta} reverse sort keys %$handler;
my $is_handled = qr/$re_str/i;
while ($raw =~ /\G([\w\d\s]*)/gi) {
$scrubbed .= $1;
my $pos = pos($raw);
if ($raw =~ /\G($is_handled)/g) {
$scrubbed .= $handler->{ lc($1) }->(\$raw);
}
unless (pos($raw)) {
if (length($raw) == $pos) {
# EXIT HERE #
return $scrubbed . $handler->{post}->(\$raw);
}
else {
my $char = substr($raw, $pos, 1);
pos($raw) = $pos + 1;
$scrubbed .= &encode_entities($char);
}
}
}
confess("I have no idea how I got here!");
}
To see it all together, just click on
d/l code
below.
For the curious I actually wrote the configuration section
first, then the function at the end and useless handlers.
(Actually ret_tag_handlers returned an empty
list.) I then grew the handlers. First I added the escape
mode. Then I started escaping tags with no attributes
allowed. Next came closing tags. And finally tags with
attributes allowed.
Enjoy. :-)