Labyrinth
view release on metacpan or search on metacpan
lib/Labyrinth/MLUtils.pm view on Meta::CPAN
zap_cp1252($str);
$str =~ s/\xE2\x80\x9A/,/g; # 82
$str =~ s/\xE2\x80\x9E/,,/g; # 84
$str =~ s/\xE2\x80\xA6/.../g; # 85
$str =~ s/\xCB\x86/^/g; # 88
$str =~ s/\xE2\x80\x98/`/g; # 91
$str =~ s/\xE2\x80\x99/'/g; # 92
$str =~ s/\xE2\x80\x9C/"/g; # 93
$str =~ s/\xE2\x80\x9D/"/g; # 94
$str =~ s/\xE2\x80\xA2/*/g; # 95
$str =~ s/\xE2\x80\x93/-/g; # 96
$str =~ s/\xE2\x80\x94/-/g; # 97
$str =~ s/\xE2\x80\xB9/</g; # 8B
$str =~ s/\xE2\x80\xBA/>/g; # 9B
return $str;
}
=head2 HTML Handling Code
The following functions disassemble and reassemble the HTML code snippets,
validating and cleaning the code to fix any errors that may exist between the
template and content of the database.
=over 4
=item process_html ( INPUT [,LINE_BREAKS [,ALLOW]] )
=item escape_html ( INPUT )
=item unescape_html ( INPUT )
=item cleanup_attr_style
=item cleanup_attr_number
=item cleanup_attr_multilength
=item cleanup_attr_text
=item cleanup_attr_length
=item cleanup_attr_color
=item cleanup_attr_uri
=item cleanup_attr_tframe
=item cleanup_attr_trules
=item cleanup_html
=item cleanup_tag
=item cleanup_close
=item cleanup_cdata
=item cleanup_no_number
=item check_url_valid
=item cleanup_attr_inputtype
=item cleanup_attr_method
=item cleanup_attr_scriptlang
=item cleanup_attr_scripttype
=item strip_nonprintable
=back
=cut
# Configuration
my $allow_html = 0;
my $line_breaks = 1;
# End configuration
##################################################################
#
# HTML handling code
#
# The code below provides some functions for manipulating HTML.
#
# process_html ( INPUT [,LINE_BREAKS [,ALLOW]] )
#
# Returns a modified version of the HTML string INPUT, with
# any potentially malicious HTML constructs (such as java,
# javascript and IMG tags) removed.
#
# If the LINE_BREAKS parameter is present and true then
# line breaks in the input will be converted to html <br />
# tags in the output.
#
# If the ALLOW parameter is present and true then most
# harmless tags will be left in, otherwise all tags will be
# removed.
#
# escape_html ( INPUT )
#
# Returns a copy of the string INPUT with any HTML
# metacharacters replaced with character escapes.
#
# unescape_html ( INPUT )
#
# Returns a copy of the string INPUT with HTML character
# entities converted to literal characters where possible.
# Note that some entites have no 8-bit character equivalent,
# see "http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent"
# for some examples. unescape_html() leaves these entities
# in their encoded form.
#
use vars qw(%html_entities $html_safe_chars %escape_html_map $escape_html_map);
lib/Labyrinth/MLUtils.pm view on Meta::CPAN
}
sub cleanup_attr_number {
/^(\d+)$/ ? $1 : undef;
}
sub cleanup_attr_method {
/^(get|post)$/i ? lc $1 : 'post';
}
sub cleanup_attr_inputtype {
/^(text|password|checkbox|radio|submit|reset|file|hidden|image|button)$/i ? lc $1 : undef;
}
sub cleanup_attr_multilength {
/^(\d+(?:\.\d+)?[*%]?)$/ ? $1 : undef;
}
sub cleanup_attr_text {
tr/-a-zA-Z0-9_()[]{}\/?.,\\|;:&@#~=+*^%$'! \xc0-\xff//dc;
$_;
}
sub cleanup_attr_length {
/^(\d+(\%|px|em)?)$/ ? $1 : undef;
}
sub cleanup_attr_color {
/^(\w{2,20}|#[\da-fA-F]{3}|#[\da-fA-F]{6})$/ or die "color <<$_>> bad";
/^(\w{2,20}|#[\da-fA-F]{3}|#[\da-fA-F]{6})$/ ? $1 : undef;
}
sub cleanup_attr_uri {
check_url_valid($_) ? $_ : undef;
}
sub cleanup_attr_tframe {
/^(void|above|below|hsides|lhs|rhs|vsides|box|border)$/i
? lc $1 : undef;
}
sub cleanup_attr_trules {
/^(none|groups|rows|cols|all)$/i ? lc $1 : undef;
}
sub cleanup_attr_scriptlang {
/^(javascript)$/i ? lc $1 : undef;
}
sub cleanup_attr_scripttype {
/^(text\/javascript)$/i ? lc $1 : undef;
}
use vars qw(@stack $safe_tags $convert_nl);
sub cleanup_html {
local ($_, $convert_nl, $safe_tags) = @_;
local @stack = ();
return '' unless($_);
my $ignore_comments = 0;
if($ignore_comments) {
s[
(?: <!--.*?--> ) |
(?: <[?!].*?> ) |
(?: <([a-z0-9]+)\b((?:[^>'"]|"[^"]*"|'[^']*')*)> ) |
(?: </([a-z0-9]+)> ) |
(?: (.[^<]*) )
][
defined $1 ? cleanup_tag(lc $1, $2) :
defined $3 ? cleanup_close(lc $3) :
defined $4 ? cleanup_cdata($4) :
''
]igesx;
} else {
s[
(?: (<!--.if.*?endif.-->) ) |
(?: <!--.*?--> ) |
(?: <[?!].*?> ) |
(?: <([a-z0-9]+)\b((?:[^>'"]|"[^"]*"|'[^']*')*)> ) |
(?: </([a-z0-9]+)> ) |
(?: (.[^<]*) )
][
defined $1 ? $1 :
defined $2 ? cleanup_tag(lc $2, $3) :
defined $4 ? cleanup_close(lc $4) :
defined $5 ? cleanup_cdata($5) :
''
]igesx;
}
# Close anything that was left open
$_ .= join '', map "</$_->{NAME}>", @stack;
# Where we turned <i><b>foo</i></b> into <i><b>foo</b></i><b></b>,
# take out the pointless <b></b>.
1 while s#<($auto_deinterleave_pattern)\b[^>]*>( |\s)*</\1>##go;
# cleanup p elements
s!\s+</p>!</p>!g;
s!<p></p>!!g;
# Element pre is not declared in p list of possible children
s!<p>\s*(<pre>.*?</pre>)\s*</p>!$1!g;
return $_;
}
sub cleanup_tag {
my ($tag, $attrs) = @_;
unless (exists $safe_tags->{$tag}) {
return '';
}
# for XHTML conformity
$tag = $transpose_tag{$tag} if($transpose_tag{$tag});
my $html = '';
if($force_closetag{$tag}) {
while (scalar @stack and $force_closetag{$tag}{$stack[0]{NAME}}) {
$html = cleanup_close($stack[0]{NAME});
}
}
my $t = $safe_tags->{$tag};
my $safe_attrs = '';
while ($attrs =~ s#^\s*(\w+)(?:\s*=\s*(?:([^"'>\s]+)|"([^"]*)"|'([^']*)'))?##) {
my $attr = lc $1;
my $val = ( defined $2 ? $2 :
defined $3 ? unescape_html($3) :
defined $4 ? unescape_html($4) :
'$attr'
);
unless (exists $t->{$attr}) {
next;
}
if (defined $t->{$attr}) {
local $_ = $val;
my $cleaned = &{ $t->{$attr} }();
if (defined $cleaned) {
$safe_attrs .= qq| $attr="${\( escape_html($cleaned) )}"|;
}
} else {
$safe_attrs .= " $attr";
}
}
my $str;
if (exists $tag_is_empty{$tag}) {
$str = "$html<$tag$safe_attrs />";
} elsif (exists $closetag_is_optional{$tag}) {
$str = "$html<$tag$safe_attrs>";
# } elsif (exists $closetag_is_dependent{$tag} && $safe_attrs =~ /$closetag_is_dependent{$tag}=/) {
# return "$html<$tag$safe_attrs />";
} else {
my $full = "<$tag$safe_attrs>";
unshift @stack, { NAME => $tag, FULL => $full };
$str = "$html$full";
}
#LogDebug("cleanup_tag: str=$str");
return $str;
}
sub cleanup_close {
my $tag = shift;
# for XHTML conformity
$tag = $transpose_tag{$tag} if($transpose_tag{$tag});
# Ignore a close without an open
unless (grep {$_->{NAME} eq $tag} @stack) {
return '';
}
# Close open tags up to the matching open
my @close = ();
while (scalar @stack and $stack[0]{NAME} ne $tag) {
push @close, shift @stack;
}
push @close, shift @stack;
my $html = join '', map {"</$_->{NAME}>"} @close;
# Reopen any we closed early if all that were closed are
# configured to be auto deinterleaved.
unless (grep {! exists $auto_deinterleave{$_->{NAME}} } @close) {
pop @close;
$html .= join '', map {$_->{FULL}} reverse @close;
unshift @stack, @close;
}
return $html;
}
sub cleanup_cdata {
local $_ = shift;
return $_ if(scalar @stack and $stack[0]{NAME} eq 'script');
s[ (?: & (
[a-zA-Z0-9]{2,15} |
[#][0-9]{2,6} |
[#][xX][a-fA-F0-9]{2,6} | ) \b ;?
) | ($escape_html_map) | (.)
][
defined $1 ? "&$1;" : defined $2 ? $2 : $3
]gesx;
# substitute newlines in the input for html line breaks if required.
s%\cM?\n%<br />\n%g if $convert_nl;
return $_;
}
# subroutine to escape the necessary characters to the appropriate HTML
# entities
sub escape_html {
my $str = shift or return '';
$str = encode_entities($str);
$str =~ s/&(#x?\d+;)/&$1/g; # avoid double encoding of hex/dec characters
return $str;
}
# subroutine to unescape escaped HTML entities. Note that some entites
# have no 8-bit character equivalent, see
# "http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent" for some examples.
# unescape_html() leaves these entities in their encoded form.
sub unescape_html {
my $str = shift or return '';
$str = decode_entities($str);
return strip_nonprintable($str);
}
sub check_url_valid {
my $url = shift;
$url = "$tvars{cgipath}/$tvars{script}$url" if($url =~ /^\?/);
# allow in page URLs
return 1 if $url =~ m!^\#!;
# allow relative URLs with sane values
return 1 if $url =~ m!^[a-z0-9_\-\.\,\+\/#]+$!i;
# allow mailto email addresses
return 1 if $url =~ m#mailto:([-+=\w\'.\&\\//]+)@((\[[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.)|(([a-zA-Z0-9\-]+\.)+))([a-zA-Z]{2,4}|[0-9]{1,3})(\]?)#i;
# allow javascript calls
return 1 if $url =~ m#^javascript:#i;
# $url =~ m< ^ ((?:ftp|http|https):// [\w\-\.]+ (?:\:\d+)?)?
# (?: /? [\w\-.!~*'(|);/\@+\$,%#]* )?
# (?: \? [\w\-.!~*'(|);/\@&=+\$,%#]* )?
( run in 1.606 second using v1.01-cache-2.11-cpan-6aa56a78535 )