AttrHTML: Model-Helper für sicheres HTML in RDB-Models

diff --git a/SL/DB/Helper/AttrHTML.pm b/SL/DB/Helper/AttrHTML.pm
new file mode 100644 (file)
index 0000000..b579972
--- /dev/null
+++ b/SL/DB/Helper/AttrHTML.pm
@@ -0,0 +1,162 @@
+package SL::DB::Helper::AttrHTML;
+
+use strict;
+
+use parent qw(Exporter);
+our @EXPORT = qw(attr_html);
+
+use utf8;
+use Carp;
+use Encode ();
+use HTML::Restrict ();
+use HTML::Parser;
+
+my %stripper;
+
+sub _strip_html {
+  my ($value) = @_;
+
+  if (!%stripper) {
+    %stripper = ( parser => HTML::Parser->new );
+
+    $stripper{parser}->handler(text => sub { $stripper{text} .= $_[1]; });
+  }
+
+  $stripper{text} = '';
+  $stripper{parser}->parse($value);
+  $stripper{parser}->eof;
+
+  return delete $stripper{text};
+}
+
+sub attr_html {
+  my ($package, $attributes, %params) = @_;
+
+  # Set default parameters:
+  $params{with_stripped}   //= 1;
+  $params{with_restricted} //= 1;
+  $params{allowed_tags}    //= { map { ($_ => ['/']) } qw(b strong i em u ul ol li sub sup s strike br p div) };
+  $attributes                = [ $attributes ] unless ref($attributes) eq 'ARRAY';
+
+  # Do the work
+  foreach my $attribute (@{ $attributes }) {
+    _make_stripped(  $package, $attribute, %params) if ($params{with_stripped});
+    _make_restricted($package, $attribute, %params) if ($params{with_restricted});
+  }
+}
+
+sub _make_stripped {
+  my ($package, $attribute, %params) = @_;
+
+  no strict 'refs';
+
+  *{ $package . '::' . $attribute . '_as_stripped_html' } = sub {
+    my ($self, $value) = @_;
+
+    return $self->$attribute(_strip_html($value)) if @_ > 1;
+    return _strip_html($self->$attribute);
+  };
+}
+
+sub _make_restricted {
+  my ($package, $attribute, %params) = @_;
+
+  no strict 'refs';
+
+  my $cleaner = HTML::Restrict->new(rules => $params{allowed_tags});
+
+  *{ $package . '::' . $attribute . '_as_restricted_html' } = sub {
+    my ($self, $value) = @_;
+
+    return $self->$attribute($cleaner->process($value)) if @_ > 1;
+    return $cleaner->process($self->$attribute);
+  };
+}
+
+1;
+__END__
+
+=pod
+
+=encoding utf8
+
+=head1 NAME
+
+SL::DB::Helper::AttrHTML - Attribute helper for stripping
+all/restricting to wanted HTML tags in columns
+
+=head1 SYNOPSIS
+
+  # In a Rose model:
+  use SL::DB::Helper::AttrHTML;
+  __PACKAGE__->attr_as_html(
+    'content',
+    with_stripped => 0,
+    allowed_tags  => { b => [ '/' ], i => [ '/' ] },
+  );
+
+  # Use in HTML templates (no usage of HTML.escape() here!):
+  <div>
+    This is the post's content:<br>
+    [% SELF.obj.content_as_restricted_html %]
+  </div>
+
+  # Writing to it from a form:
+  <form method="post">
+    ...
+    [% L.textarea_tag('post.content_as_restricted_html', SELF.obj.content_as_restricted_html) %]
+  </form>
+
+=head1 OVERVIEW
+
+Sometimes you want an HTML editor on your web page. However, you only
+want to allow certain tags. You also need to repeat that stuff when
+displaying it without risking HTML/JavaScript injection attacks.
+
+This plugin provides two helper methods for an attribute:
+C<attribute_as_stripped_html> which removes all HTML tags, and
+C<attribute_as_restricted_html> which removes all but a list of safe
+HTML tags. Both are simple accessor methods.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item C<attr_html $attributes, [%params]>
+
+Package method. Call with the name of the attributes (either a scalar
+for a single attribute or an array reference for multiple attributes)
+for which the helper methods should be created.
+
+C<%params> can include the following options:
+
+=over 2
+
+=item * C<with_stripped> is a scalar that controls the creation of the
+C<attribute_as_stripped_html> method. It is on by default.
+
+=item * C<with_restricted> is a scalar that controls the creation of the
+C<attribute_as_restricted_html> method. It is on by default. If it is
+on then the parameter C<allowed_tags> contains the tags that are kept
+by this method.
+
+=item * C<allowed_tags> must be a hash reference containing the tags
+and attributes to keep. It follows the same structural layout as the
+C<rules> parameter of L<HTML::Restrict/new>. Only relevant if
+C<with_restricted> is trueish. It defaults to allow the following tags
+without any attribute safe the trailing slash: C<b i u ul ol li sub
+sup strike br p div>.
+
+=back
+
+=back
+
+=head1 BUGS
+
+Nothing here yet.
+
+=head1 AUTHOR
+
+Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
+
+=cut

diff --git a/SL/InstallationCheck.pm b/SL/InstallationCheck.pm
index 3d30564..78a5f62 100644 (file)
--- a/SL/InstallationCheck.pm
+++ b/SL/InstallationCheck.pm
@@ -28,6 +28,8 @@ BEGIN {
   { name => "FCGI",            version => '0.72',  url => "http://search.cpan.org/~mstrout/",   debian => 'libfcgi-perl' },
   { name => "File::Copy::Recursive",               url => "http://search.cpan.org/~dmuey/",     debian => 'libfile-copy-recursive-perl' },
   { name => "GD",                                  url => "http://search.cpan.org/~lds/",       debian => 'libgd-gd2-perl', },
+  { name => 'HTML::Parser',                        url => 'http://search.cpan.org/~gaas/',      debian => 'libhtml-parser-perl', },
+  { name => 'HTML::Restrict',                      url => 'http://search.cpan.org/~oalders/', },
   { name => "Image::Info",                         url => "http://search.cpan.org/~srezic/",    debian => 'libimage-info-perl' },
   { name => "JSON",                                url => "http://search.cpan.org/~makamaka",   debian => 'libjson-perl' },
   { name => "List::MoreUtils", version => '0.21',  url => "http://search.cpan.org/~vparseval/", debian => 'liblist-moreutils-perl' },