cdata results from the CPAN

cdata

HTML-Defang

view release on metacpan or search on metacpan

  mtd => 1,
  maligngroup => 1,
  malignmark => 1,
  mlabeledtr => 1,
  maction => 1,
);

# Some entity conversions for attributes
my $CtrlChars = qr/[\x00-\x08\x0b-\x1f]/;
my %EntityToChar = (quot => '"', apos => "'", amp => '&', 'lt' => '<', 'gt' => '>');
my %CharToEntity = ((reverse %EntityToChar), ' ' => '#x20', '/' => '#x2f', "\x09" => '#x09', "\x0a" => '#x0a');
my %QuoteRe = ('"' => qr/(["&<>\x09\x0a])/, "'" => qr/(['&<>\x09\x0a])/, "" => qr/(['"&<> \/\x09\x0a])/);

# When fixing mismatched tags, sometimes a close tag
#  shouldn't close all the way out
# For example, consider:
#   <table><tr><td><table><tr></td>
# A naive version would see the ending </td>, and thus
#  try to fix the mismatched tags by doing:
#   <table><tr><td><table><tr></tr></table></td>
# This is not what a browser does. So given a tag, we
#  give a list of closing tags which cause us to stop
#  and not close any more
my %MismatchedTagNest = (
  table => [ qw(tbody thead tfoot tr th td caption colgroup col) ],
  tbody => [ qw(tr th td) ],
  tr => [ qw(th td) ],
  font => [ '' ],
);
# Convert to hash of hashes
$_ = { map { $_ => 1 } @$_ } for values %MismatchedTagNest;

# If we see a table, we should expect to see a tbody
#  next. If not, we need to add it because the browser
#  will implicitly open it!
# For each tag, give list of tags that should follow. If
#  we don't find one of them following, we open a new
#  implicit tag of the first one in the list
#  eg. <table><td> -> <table><tr><td>
my %ImplicitOpenTags = (
  table => [ qw(tr tbody thead tfoot caption colgroup col) ],
  thead => [ qw(tr) ],
  tbody => [ qw(tr) ],
  tr => [ qw(td th) ],
);
# Convert to hash of hashes
$_ = { default => $_->[0], map { $_ => 1 } @$_ } for values %ImplicitOpenTags;

my %TableTags = map { $_ => 1 } qw(table tbody thead tfoot tr td th caption colgroup col);
my %BlockTags = map { $_ => 1 } qw(h1 h2 h3 h4 h5 h6 p div pre plaintext address blockquote center form table tbody thead tfoot tr td th caption colgroup col dl ul ol li fieldset);
my %InlineTags = map { $_ => 1 } qw(span abbr acronym q sub sup cite code em kbd samp strong var dfn strike b i u s tt small big nobr a font);
my %NestInlineTags = map { $_ => 1 } qw(span abbr acronym q sub sup cite code em kbd samp strong var dfn strike b i u s tt small big nobr);

# Default list of mismatched tags to track
my %MismatchedTags = (%BlockTags, %InlineTags);

# Elements whose contents are RCDATA (title, textarea) or RAWTEXT (noembed,
#  noframes): the browser does not parse comments or nested tags inside them,
#  only a matching end tag. We must consume their content as opaque text
#  rather than parsing it as HTML, or an attacker can smuggle a literal end
#  tag + active markup past us. See defang_rcdata_content(). (<script>,
#  <style> and the defanged raw-text tags like <xmp>/<iframe> are handled
#  separately.)
my %RawTextTags = map { $_ => 1 } qw(title textarea noembed noframes);

=head1 CONSTRUCTOR

=over 4

=cut

=item I<HTML::Defang-E<gt>new(%Options)>

Constructs a new HTML::Defang object. The following options are supported:

=over 4

=item B<Options>

=over 4

=item B<tags_to_callback>

Array reference of tags for which a call back should be made. If a tag in this array is parsed, the subroutine tags_callback() is invoked.

=item B<attribs_to_callback>

Array reference of tag attributes for which a call back should be made. If an attribute in this array is parsed, the subroutine attribs_callback() is invoked.

=item B<tags_callback>

Subroutine reference to be invoked when a tag listed in @$tags_to_callback is parsed.

=item B<attribs_callback>

Subroutine reference to be invoked when an attribute listed in @$attribs_to_callback is parsed.

=item B<url_callback>

Subroutine reference to be invoked when a URL is detected in an HTML tag attribute or a CSS property.

=item B<css_callback>

Subroutine reference to be invoked when CSS data is found either as the contents of a 'style' attribute in an HTML tag, or as the contents of a <style> HTML tag.

=item B<content_callback>

Subroutine reference to be invoked when standard content between HTML tags in found.

=item B<fix_mismatched_tags>

This property, if set, fixes mismatched tags in the HTML input. By default, tags present in the default %mismatched_tags_to_fix hash are fixed. This set of tags can be overridden by passing in an array reference $mismatched_tags_to_fix to the constru...

=item B<mismatched_tags_to_fix>

Array reference of tags for which the code would check for matching opening and closing tags. See the property $fix_mismatched_tags.

=item B<context>

You can pass an arbitrary scalar as a 'context' value that's then passed as the first parameter to all callback functions. Most commonly this is something like '$Self'

lib/HTML/Defang.pm view on Meta::CPAN


        # Skip attribute parsing if none
        my @Attributes;
        goto NoParseAttributes if $I =~ m{\G>}gcso;

        # Pull off any trailing component after the tag
        # Now match all key=value attributes
        while ($I =~ m{\G(?:($AttrKeyStartLineRE)(\s*))?(?:(=\s*)($AttrValRE)(\s*))?}gcso) {

          last if !defined($1) && !defined($4);
          my ($Attribute, $AttrTrail, $Equals, $AttrVal, $AttrValTrail) = ($1, $2, $3, $4, $5);
          my ($AttrQuote, $AttrValWithoutQuote) = '';
          if (defined($4) && $4 =~ /^([`"']?)(.*)\1$/s) {
            # IE supports `, but nothing else does, turn it into "
            $AttrQuote = $1 eq '`' ? '"' : $1;
            $AttrValWithoutQuote = $2;
          }

          # Turn on utf-8 for things that might be
          Encode::_utf8_on($Attribute) if $UTF8Input;
          Encode::_utf8_on($AttrValWithoutQuote) if $UTF8Input;

          push @Attributes, [ $Attribute, $AttrTrail, $Equals, $AttrQuote, $AttrValWithoutQuote, $AttrQuote, $AttrValTrail ];
          warn "defang AttributeKey=$1 AttrQuote=$AttrQuote AttributeValue=$Attribute" if $Debug;
        }

        # Better be at end of attributes, or attach our own ending tag
        if ($I =~ m{\G(?:(\s*[/\\]*\s*(?:--)?\s*)?>|([\s/-]*))}gcs) {
          $CloseAngle = $1 ? $1 . '>' : ($2 ? $2 . '>' : '>');
        }

        NoParseAttributes:
        my $Defang = DEFANG_ALWAYS;

        my $lcTag = lc $Tag;
        my $TagOps = $Tags{$lcTag};

        # Process this tag
        if (!exists $Self->{tags_to_callback}->{$lcTag} && ref $TagOps eq "CODE") {

          warn "process_tag Found CODE reference" if $Debug;
          $Defang = $Self->${TagOps}($OutR, \$I, $TagOps, \$OpenAngle, $IsEndTag, $lcTag, $TagTrail, \@Attributes, \$CloseAngle);

        } else {

          warn "process_tag Found regular tag" if $Debug;
          $Defang = $Self->defang_attributes($OutR, \$I, $TagOps, \$OpenAngle, $IsEndTag, $lcTag, $TagTrail, \@Attributes, \$CloseAngle);

        }
        die "Callback reset pos on Tag=$Tag IsEndTag=$IsEndTag" if !defined pos($I);
        warn "defang Defang=$Defang" if $Debug;

        # RCDATA/RAWTEXT elements (title, textarea, noembed, noframes): their
        #  content is opaque text to a browser, not HTML. Consume it verbatim
        #  up to the matching end tag so we don't parse comments/tags inside
        #  it (which would let an attacker smuggle a literal end tag + active
        #  markup past the defanger). Skipped if a user tags_callback owns the
        #  tag, since it is then responsible for the content.
        if (!$IsEndTag && $RawTextTags{$lcTag}
            && !exists $Self->{tags_to_callback}->{$lcTag}) {
          $Self->defang_rcdata_content(\$I, $lcTag);
        }

        # Build tag content, because if we defang, we have to remove --'s within it

        # @Attributes can have unicode values, but we're within "use bytes", so it's flattened ok
        my $TagContent = $TagTrail . join("", grep { defined } map { @$_ } @Attributes);

        if ($Self->{fix_mismatched_tags} && ($Defang == DEFANG_NONE)) {
          if (!$IsEndTag) {
            $Defang = $Self->open_tag(0, $OutR, \$I, $lcTag, \$TagContent);
          } else {
            $Defang = $Self->close_tag(0, $OutR, \$I, $lcTag);
            goto SkipOutput if $Defang == DEFANG_ALWAYS;
          }
        }

        # defang unknown tags
        if ($Defang != DEFANG_NONE) {
          warn "defang Defanging $Tag" if $Debug;
          if ($Self->{delete_defang_content}) {
            $OpenAngle = $IsEndTag = $Tag = $TagContent = $CloseAngle = '';
          } else {
            $Tag = $Self->{defang_string} . $Tag
              if $Self->{allow_double_defang} || $Tag !~ $Self->{defang_re};
            $TagContent =~ s/--//g;
            $Tag =~ s/--//g;
            $OpenAngle =~ s/^</<!--/;
            $CloseAngle =~ s/>$/-->/;
          }
        }

        # And put it all back together into the output string
        $$OutR .= $OpenAngle . $IsEndTag . $Tag . $TagContent . $CloseAngle;
        SkipOutput:

      # It's a comment of some sort. We are looking for regular HTML comment, XML CDATA section
      } elsif ($I =~ m{\G(!)((?:\[CDATA\[|--)?)}gcis) {

        my ($Comment, $CommentDelim) = ($1, $2);
        warn "defang Comment=$Comment CommentDelim=$CommentDelim" if $Debug;

        # Find the appropriate closing delimiter
        my $IsCDATA = $CommentDelim eq "[CDATA[";
        my $ClosingCommentDelim = $IsCDATA ? "]]" : $CommentDelim;

        warn "defang ClosingCommentDelim=$ClosingCommentDelim" if $Debug;

        my ($CommentStartText, $CommentEndText) = ("--/*SC*/", "/*EC*/--");

        # Convert to regular HTML comment
        if (!$Self->{delete_defang_content}) {
          $$OutR .= $OpenAngle . $Comment . $CommentStartText;
        }

        # Find closing comment
        if ($I =~ m{\G(.*?)(\Q$ClosingCommentDelim\E!?\s*)(>)}gcis || $I =~ m{\G(.*?)(--)(>)}gcis) {

          my ( $StartTag, $CommentData, $ClosingTag, $CloseAngle ) =
            ( $CommentDelim, $1, $2, $3 );

lib/HTML/Defang.pm view on Meta::CPAN


=item I<$OpenAngle>

Opening angle(<) sign of the current tag.

=item I<$IsEndTag>

Has the value '/' if the current tag is a closing tag.

=item I<$Tag>

The HTML tag that is currently being parsed.

=item I<$TagTrail>

Any space after the tag, but before attributes.

=item I<$Attributes>

A reference to an array of the attributes and their values, including any surrouding spaces. Each element of the array is added by 'push' calls like below.

  push @$Attributes, [ $AttributeName, $SpaceBeforeEquals, $EqualsAndSubsequentSpace, $QuoteChar, $AttributeValue, $QuoteChar, $SpaceAfterAtributeValue ];

=item I<$CloseAngle>

Anything after the end of last attribute including the closing HTML angle(>)

=back

=back

=cut
sub defang_script_tag {
  my $Self = shift;
  my ($OutR, $HtmlR, $TagOps, $OpenAngle, $IsEndTag, $lcTag, $TagTrail, $Attributes, $CloseAngle) = @_;
  warn "defang_script Processing <script> tag" if $Self->{Debug};

  if (!$IsEndTag) {

    # If we just parsed a starting <script> tag, find up to end tag
    #  There's all sort of possible mess around this:
    #   </script<foo> - not really an end tag
    #   </script foo="bar > yes, still in a attribute"> - a valid end tag
    #  For weird cases, we end script tag early and end up defanging script
    #  content as HTML content, which is still safe
    if ($$HtmlR =~ m{\G(.*?)(?=</script\b)}gcsi) {
      my $ScriptTagContents = $1;
      warn "defang_script ScriptTagContents $ScriptTagContents" if $Self->{Debug};
      if (!$Self->{delete_defang_content}) {
        1 while $ScriptTagContents =~ s/<!--|-->|--//g;
        $ScriptTagContents = "<!-- " . $ScriptTagContents . " -->";
        $Self->add_to_output($ScriptTagContents);
      }
    }
  }

  # Also defang tag
  return DEFANG_ALWAYS;
}

=item I<defang_rcdata_content($HtmlR, $lcTag)>

Consume the RCDATA/RAWTEXT content of a "text" element and pass it straight
through to the output as opaque text.

The elements this applies to are C<< <title> >> and C<< <textarea> >>
(RCDATA) and C<< <noembed> >> and C<< <noframes> >> (RAWTEXT) - see the
listing in C<%RawTextTags>. Per the HTML5 tree construction/tokenization
spec, a start tag for one of these switches the tokenizer into a raw text
mode in which the browser does I<not> parse comments or nested tags - the
only markup it recognises is a matching C<< </tag >> end tag, everything
else is text (RCDATA additionally decodes character references). Comments in
particular are not a thing inside these elements.

If we instead let the normal HTML parser loose on the content it would
happily interpret C<< <!-- ... --> >> comments and nested tags inside. That
diverges from the browser and is exploitable: an attacker can hide a literal
end tag plus active markup inside what we think is an inert comment or
attribute value, e.g.

  <title><!-- </title> <img src=x onerror=alert(1)> --></title>

We would emit the C<< <img> >> unchanged (believing it comment data), but a
browser closes the title at the literal C<< </title> >> and then runs the
C<< <img> >> as live markup.

So, like <script> and <style>, we consume everything up to the matching
C<< </tag >> (whose name is C<$lcTag>) as opaque text. That content contains
no C<< </tag >> (we stop before the first one), so re-parsed as raw text it
stays inert right up to the end tag that follows it in the output.

=cut
sub defang_rcdata_content {
  my ($Self, $HtmlR, $lcTag) = @_;

  warn "defang_rcdata_content Tag=$lcTag" if $Self->{Debug};

  # Do the raw text scan in byte mode (see defang())
  use bytes;

  # Consume raw content verbatim up to the matching end tag (or EOF if
  #  there's no closing tag, just as a browser would leave the element open)
  if ($$HtmlR =~ m{\G(.*?)(?=</\Q$lcTag\E\b)}gcis || $$HtmlR =~ m{\G(.*)$}gcs) {
    my $Content = $1;
    warn "defang_rcdata_content Content=$Content" if $Self->{Debug};
    $Self->add_to_output($Content) if defined($Content) && length($Content);
  }

  return;
}

sub defang_style_tag {
  my ($Self, $OutR, $HtmlR, $TagOps, $OpenAngle, $IsEndTag, $lcTag, $TagTrail, $Attributes, $CloseAngle) = @_;

  warn "defang_style_tag Tag=$lcTag IsEndTag=$IsEndTag" if $Self->{Debug};

  # Defang attributes
  my $Defang = $Self->defang_attributes($OutR, $HtmlR, $TagOps, $OpenAngle, $IsEndTag, $lcTag, $TagTrail, $Attributes, $CloseAngle);

  # Nothing to do if end tag
  return $Defang if $IsEndTag;

  # Do all style work in byte mode
  use bytes;

  my $Content = '';
  my $ClosingStyleTagPresent = 1;

  for ($$HtmlR) {
    if (m{\G(.*?)(?=</style\b)}gcis) {
      $Content = $1;

    # No ending style tag
    } elsif (m{\G([^<]*)}gcis) {
      $Content = $1;
      $ClosingStyleTagPresent = 0;
    }
  }

  # Handle any wrapping HTML comments. If no comments, we add
  my ($OpeningHtmlComment, $ClosingHtmlComment) = ('', '');
  $OpeningHtmlComment = $Content =~ s{^(\s*<!--)}{} ? $1 . " " : "<!-- ";
  $ClosingHtmlComment = $Content =~ s{(-->\s*)$}{} ? " " . $1 : " -->";

  # Check for large bogus style data with mostly HTML tags and blat it
  if (length $Content > 16384) {
    my $TagCount = 0;
    $TagCount++ while $Content =~ m{</?\w+\b[^>]*>}g;
    if ($TagCount > length($Content)/256) {
      $Content = '';
    }
  }

  my $StyleOut = $Self->defang_style_text($Content, $lcTag, 0, undef, $HtmlR, $OutR);

  $Self->add_to_output($OpeningHtmlComment . $StyleOut . $ClosingHtmlComment);
  $Self->add_to_output("</style>") if !$ClosingStyleTagPresent;

  return $Defang;
}

=item I<defang_style_text($Content, $lcTag, $IsAttr, $AttributeHash, $HtmlR, $OutR)>

Defang some raw css data and return the defanged content

( run in 0.503 second using v1.01-cache-2.11-cpan-751830e7986 )