SL/DB/Helper/AttrHTML.pm

   1 package SL::DB::Helper::AttrHTML;
   2
   3 use strict;
   4
   5 use parent qw(Exporter);
   6 our @EXPORT = qw(attr_html);
   7
   8 use utf8;
   9 use Carp;
  10 use Encode ();
  11 use HTML::Restrict ();
  12 use HTML::Parser;
  13
  14 my %stripper;
  15
  16 sub _strip_html {
  17   my ($value) = @_;
  18
  19   if (!%stripper) {
  20     %stripper = ( parser => HTML::Parser->new );
  21
  22     $stripper{parser}->handler(text => sub { $stripper{text} .= $_[1]; });
  23   }
  24
  25   $stripper{text} = '';
  26   $stripper{parser}->parse($value);
  27   $stripper{parser}->eof;
  28
  29   return delete $stripper{text};
  30 }
  31
  32 sub attr_html {
  33   my ($package, $attributes, %params) = @_;
  34
  35   # Set default parameters:
  36   $params{with_stripped}   //= 1;
  37   $params{with_restricted} //= 1;
  38   $params{allowed_tags}    //= { map { ($_ => ['/']) } qw(b strong i em u ul ol li sub sup s strike br p div) };
  39   $attributes                = [ $attributes ] unless ref($attributes) eq 'ARRAY';
  40
  41   # Do the work
  42   foreach my $attribute (@{ $attributes }) {
  43     _make_stripped(  $package, $attribute, %params) if ($params{with_stripped});
  44     _make_restricted($package, $attribute, %params) if ($params{with_restricted});
  45   }
  46 }
  47
  48 sub _make_stripped {
  49   my ($package, $attribute, %params) = @_;
  50
  51   no strict 'refs';
  52
  53   *{ $package . '::' . $attribute . '_as_stripped_html' } = sub {
  54     my ($self, $value) = @_;
  55
  56     return $self->$attribute(_strip_html($value)) if @_ > 1;
  57     return _strip_html($self->$attribute);
  58   };
  59 }
  60
  61 sub _make_restricted {
  62   my ($package, $attribute, %params) = @_;
  63
  64   no strict 'refs';
  65
  66   my $cleaner = HTML::Restrict->new(rules => $params{allowed_tags});
  67
  68   *{ $package . '::' . $attribute . '_as_restricted_html' } = sub {
  69     my ($self, $value) = @_;
  70
  71     return $self->$attribute($cleaner->process($value)) if @_ > 1;
  72     return $cleaner->process($self->$attribute);
  73   };
  74 }
  75
  76 1;
  77 __END__
  78
  79 =pod
  80
  81 =encoding utf8
  82
  83 =head1 NAME
  84
  85 SL::DB::Helper::AttrHTML - Attribute helper for stripping
  86 all/restricting to wanted HTML tags in columns
  87
  88 =head1 SYNOPSIS
  89
  90   # In a Rose model:
  91   use SL::DB::Helper::AttrHTML;
  92   __PACKAGE__->attr_as_html(
  93     'content',
  94     with_stripped => 0,
  95     allowed_tags  => { b => [ '/' ], i => [ '/' ] },
  96   );
  97
  98   # Use in HTML templates (no usage of HTML.escape() here!):
  99   <div>
 100     This is the post's content:<br>
 101     [% SELF.obj.content_as_restricted_html %]
 102   </div>
 103
 104   # Writing to it from a form:
 105   <form method="post">
 106     ...
 107     [% L.textarea_tag('post.content_as_restricted_html', SELF.obj.content_as_restricted_html) %]
 108   </form>
 109
 110 =head1 OVERVIEW
 111
 112 Sometimes you want an HTML editor on your web page. However, you only
 113 want to allow certain tags. You also need to repeat that stuff when
 114 displaying it without risking HTML/JavaScript injection attacks.
 115
 116 This plugin provides two helper methods for an attribute:
 117 C<attribute_as_stripped_html> which removes all HTML tags, and
 118 C<attribute_as_restricted_html> which removes all but a list of safe
 119 HTML tags. Both are simple accessor methods.
 120
 121 =head1 FUNCTIONS
 122
 123 =over 4
 124
 125 =item C<attr_html $attributes, [%params]>
 126
 127 Package method. Call with the name of the attributes (either a scalar
 128 for a single attribute or an array reference for multiple attributes)
 129 for which the helper methods should be created.
 130
 131 C<%params> can include the following options:
 132
 133 =over 2
 134
 135 =item * C<with_stripped> is a scalar that controls the creation of the
 136 C<attribute_as_stripped_html> method. It is on by default.
 137
 138 =item * C<with_restricted> is a scalar that controls the creation of the
 139 C<attribute_as_restricted_html> method. It is on by default. If it is
 140 on then the parameter C<allowed_tags> contains the tags that are kept
 141 by this method.
 142
 143 =item * C<allowed_tags> must be a hash reference containing the tags
 144 and attributes to keep. It follows the same structural layout as the
 145 C<rules> parameter of L<HTML::Restrict/new>. Only relevant if
 146 C<with_restricted> is trueish. It defaults to allow the following tags
 147 without any attribute safe the trailing slash: C<b i u ul ol li sub
 148 sup strike br p div>.
 149
 150 =back
 151
 152 =back
 153
 154 =head1 BUGS
 155
 156 Nothing here yet.
 157
 158 =head1 AUTHOR
 159
 160 Moritz Bunkus E<lt>m.bunkus@linet-services.deE<gt>
 161
 162 =cut