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