\2} text
# remove line breaks right before and after HTML tags that will insert a paragraph break themselves
if { $includes_html_p } {
- set tags [join { ul ol li blockquote p div table tr td th } |]
+ set tags [join { ul ol li blockquote p div table tr td th } |]
regsub -all -nocase "\\s*(\]*>)\\s*" $text {\1} text
-
- #foreach tag { ul ol li blockquote p div table tr td th } {
- # regsub -all -nocase "\\n\\s*(\]*>)" $text {\1} text
- # regsub -all -nocase "(\]*>)\\s*\\n" $text {\1} text
- #}
}
# Convert _single_ CRLF's to
's to preserve line breaks
@@ -188,7 +255,7 @@
Quotes ampersands, double-quotes, and angle brackets in $arg.
Analogous to ns_quotehtml except that it quotes double-quotes (which
- ns_quotehtml does not).
+ ns_quotehtml does not).
@see ad_unquotehtml
} {
@@ -200,7 +267,7 @@
@see ad_quotehtml
} {
- return [string map {> > < < " \" & &} $arg]
+ return [string map {& & > > < < " \" " \" ' '} $arg]
}
@@ -210,23 +277,23 @@
#
####################
+
#
# lars@pinds.com, 19 July 2000:
# Should this proc change name to something in line with the rest
# of the library?
#
-
ad_proc -private util_close_html_tags {
- html_fragment
- {break_soft 0}
+ html_fragment
+ {break_soft 0}
{break_hard 0}
{ellipsis ""}
{more ""}
} {
Given an HTML fragment, this procedure will close any tags that
have been left open. The optional arguments let you specify that
- the fragment is to be truncated to a certain number of displayable
- characters. After break_soft, it truncates and closes open tags unless
+ the fragment is to be truncated to a certain number of displayable
+ characters. After break_soft, it truncates and closes open tags unless
you're within non-breaking tags (e.g., Af). After break_hard displayable
characters, the procedure simply truncates and closes any open HTML tags
that might have resulted from the truncation.
@@ -239,25 +306,23 @@
Each element of that list is either a single element, if the attribute had no value, or - a two-tuple, with the first element being the name of the attribute and the second being + a two-tuple, with the first element being the name of the attribute and the second being the value. The attribute names are all converted to lowercase.
If you don't really care what happens when the same attribute is present twice, you can also use the
attribute_array argument, and the attributes will be
set there. For attributes without any value, we'll use the empty string.
- Example: + Example:
set html {<tag foo = bar baz greble=""hello you sucker"" foo='blah' Heres = ' something for you to = "consider" '>}
-set pos 5 ; # the 'f' in the first 'foo'
+ set pos 5 ; # the 'f' in the first 'foo'
-set attribute_list [ad_parse_html_attributes_upvar -attribute_array attribute_array html pos]
+ set attribute_list [ad_parse_html_attributes_upvar -attribute_array attribute_array html pos]
attribute_list will contain the following:
-{foo bar} baz {greble {"hello you sucker"}} {foo blah} {heres { something for you to = "consider" }}
+ {foo bar} baz {greble {"hello you sucker"}} {foo blah} {heres { something for you to = "consider" }}
attribute_array will contain:
-attribute_array(foo)='blah' -attribute_array(greble)='"hello you sucker"' -attribute_array(baz)='' -attribute_array(heres)=' something for you to = "consider" '+
attribute_array(foo)='blah' + attribute_array(greble)='"hello you sucker"' + attribute_array(baz)='' + attribute_array(heres)=' something for you to = "consider" '
@@ -616,8 +687,8 @@
start. This should point to a character inside the tag, just after
the tag name, and before the first attribute. Note, that we will modify this variable.
When this proc is done, this variable will point to the tag-closing >.
- Example:
- if the tag is <img src="foo">, pos_varname should point to either the space between
+ Example:
+ if the tag is <img src="foo">, pos_varname should point to either the space between
img and src, or the s in src.
@param attribute_array This is an alternate way of returning the attributes, if you don't care
@@ -626,12 +697,12 @@
@return A list of list holding the attribute names and
values. Each element of that list is either a single element, if the
attribute had no value, or
- a two-tuple, with the first element being the name of the attribute and the second being
+ a two-tuple, with the first element being the name of the attribute and the second being
the value. The attribute names are all converted to lowercase.
@author Lars Pind (lars@pinds.com)
@creation-date November 10, 2000
-} {
+} {
upvar $html_varname html
upvar $pos_varname i
if { [info exists attribute_array] } {
@@ -652,641 +723,1083 @@
# This is an XML-style tag ending: <... />
break
}
-
- # This regexp matches an attribute name and an equal sign, if present.
- # Also eats whitespace before or after.
- # The \A corresponds to ^, except it matches the position we're starting from, not the start of the string
+
+ # This regexp matches an attribute name and an equal sign, if
+ # present. Also eats whitespace before or after. The \A
+ # corresponds to ^, except it matches the position we're
+ # starting from, not the start of the string.
if { ![regexp -indices -start $i {\A\s*([^\s=>]+)\s*(=?)\s*} $html match attr_name_idx equal_sign_idx] } {
- # Apparantly, there's no attribute name here. Let's eat all whitespace and lonely equal signs.
+ #
+ # Apparently, there's no attribute name here.
+ # Let's eat all whitespace and lonely equal signs.
+ #
regexp -indices -start $i {\A[\s=]*} $html match
set i [expr { [lindex $match 1] + 1 }]
} {
set attr_name [string tolower [string range $html [lindex $attr_name_idx 0] [lindex $attr_name_idx 1]]]
-
+
# Move past the attribute name just found
set i [expr { [lindex $match 1] + 1}]
-
+
# If there is an equal sign, we're expecting the next token to be a value
if { [lindex $equal_sign_idx 1] - [lindex $equal_sign_idx 0] < 0 } {
# No equal sign, no value
- lappend attributes [list $attr_name]
+ lappend attributes [list $attr_name]
if { [info exists attribute_array] } {
set attribute_array_var($attr_name) {}
}
} else {
-
+
# is there a single or double quote sign as the first character?
switch -- [string index $html $i] {
{"} { set exp {\A"([^"]*)"\s*} }
- {'} { set exp {\A'([^']*)'\s*} }
- default { set exp {\A([^\s>]*)\s*} }
- }
- if { ![regexp -indices -start $i $exp $html match attr_value_idx] } {
- # No end quote.
- set attr_value [string range $html $i+1 end]
- set i [string length $html]
- } else {
- set attr_value [string range $html [lindex $attr_value_idx 0] [lindex $attr_value_idx 1]]
- set i [expr { [lindex $match 1] + 1}]
- }
+ {'} { set exp {\A'([^']*)'\s*} }
+ default { set exp {\A([^\s>]*)\s*} }
+ }
+ if { ![regexp -indices -start $i $exp $html match attr_value_idx] } {
+ # No end quote.
+ set attr_value [string range $html $i+1 end]
+ set i [string length $html]
+ } else {
+ set attr_value [string range $html [lindex $attr_value_idx 0] [lindex $attr_value_idx 1]]
+ set i [expr { [lindex $match 1] + 1}]
+ }
- set attr_value [util_expand_entities_ie_style $attr_value]
-
- lappend attributes [list $attr_name $attr_value]
- if { [info exists attribute_array] } {
- set attribute_array_var($attr_name) $attr_value
+ set attr_value [util_expand_entities_ie_style $attr_value]
+
+ lappend attributes [list $attr_name $attr_value]
+ if { [info exists attribute_array] } {
+ set attribute_array_var($attr_name) $attr_value
+ }
}
}
}
+ return $attributes
}
- return $attributes
-}
-ad_proc ad_html_security_check { html } {
+ ad_proc ad_html_security_check { html } {
- Returns a human-readable explanation if the user has used any HTML
- tag other than the ones marked allowed in antispam section of ad.ini.
- Otherwise returns an empty string.
-
- @return a human-readable, plaintext explanation of what's wrong with the user's input.
-
- @author Lars Pind (lars@pinds.com)
- @creation-date 20 July 2000
+ Returns a human-readable explanation if the user has used any HTML
+ tag other than the ones marked allowed in antispam section of ad.ini.
+ Otherwise returns an empty string.
-} {
- if { [string first <% $html] > -1 } {
- return "For security reasons, you're not allowed to have the less-than-percent combination in your input."
- }
-
- array set allowed_attribute [list]
- array set allowed_tag [list]
- array set allowed_protocol [list]
+ @return a human-readable, plaintext explanation of what's wrong with the user's input.
- # Use the antispam tags for this package instance and whatever is on the kernel.
- set allowed_tags_list [concat \
- [ad_parameter_all_values_as_list -package_id [ad_acs_kernel_id] AllowedTag antispam] \
- [ad_parameter_all_values_as_list AllowedTag antispam]]
+ @author Lars Pind (lars@pinds.com)
+ @creation-date 20 July 2000
- set allowed_attributes_list [concat \
- [ad_parameter_all_values_as_list -package_id [ad_acs_kernel_id] AllowedAttribute antispam] \
- [ad_parameter_all_values_as_list AllowedAttribute antispam]]
+ } {
+ if { [string first <% $html] > -1 } {
+ return "For security reasons, you're not allowed to have the less-than-percent combination in your input."
+ }
- set allowed_protocols_list [concat \
- [ad_parameter_all_values_as_list -package_id [ad_acs_kernel_id] AllowedProtocol antispam] \
- [ad_parameter_all_values_as_list AllowedProtocol antispam]]
+ array set allowed_attribute [list]
+ array set allowed_tag [list]
+ array set allowed_protocol [list]
- foreach tag $allowed_tags_list {
- set allowed_tag([string tolower $tag]) 1
- }
- foreach attribute $allowed_attributes_list {
- set allowed_attribute([string tolower $attribute]) 1
- }
- foreach tagname $allowed_tags_list {
- set allowed_tag([string tolower $tagname]) 1
- }
- foreach protocol $allowed_protocols_list {
- set allowed_protocol([string tolower $protocol]) 1
- }
-
- # loop over all tags
- for { set i [string first < $html] } { $i != -1 } { set i [string first < $html $i] } {
- # move past the tag-opening <
- incr i
+ # Use the antispam tags for this package instance and whatever is on the kernel.
+ set allowed_tags_list [concat \
+ [ad_parameter_all_values_as_list -package_id [ad_acs_kernel_id] AllowedTag antispam] \
+ [ad_parameter_all_values_as_list AllowedTag antispam]]
- if { ![regexp -indices -start $i {\A/?([-_a-zA-Z0-9]+)\s*} $html match name_idx] } {
- # The tag-opener isn't followed by USASCII letters (with or without optional inital slash)
- # Not considered a tag. Shouldn't do any harm in browsers.
- # (Tested with digits, with A syntax, with whitespace)
- } else {
- # The tag was valid ... now let's see if it's on the allowed list.
- set tagname [string tolower [string range $html [lindex $name_idx 0] [lindex $name_idx 1]]]
+ set allowed_attributes_list [concat \
+ [ad_parameter_all_values_as_list -package_id [ad_acs_kernel_id] AllowedAttribute antispam] \
+ [ad_parameter_all_values_as_list AllowedAttribute antispam]]
- if { ![info exists allowed_tag($tagname)] && ![info exists allowed_tag(*)] } {
- # Nope, this was a naughty tag.
- return "For security reasons we only accept the submission of HTML
- containing the following tags: [join $allowed_tags_list " "].
- You have a [string toupper $tagname] tag in there."
+ set allowed_protocols_list [concat \
+ [ad_parameter_all_values_as_list -package_id [ad_acs_kernel_id] AllowedProtocol antispam] \
+ [ad_parameter_all_values_as_list AllowedProtocol antispam]]
+
+ foreach attribute $allowed_attributes_list {
+ set allowed_attribute([string tolower $attribute]) 1
+ }
+ foreach tagname $allowed_tags_list {
+ set allowed_tag([string tolower $tagname]) 1
+ }
+ foreach protocol $allowed_protocols_list {
+ set allowed_protocol([string tolower $protocol]) 1
+ }
+
+ # loop over all tags
+ for { set i [string first < $html] } { $i != -1 } { set i [string first < $html $i] } {
+ # move past the tag-opening <
+ incr i
+
+ if { ![regexp -indices -start $i {\A/?([-_a-zA-Z0-9]+)\s*} $html match name_idx] } {
+ # The tag-opener isn't followed by USASCII letters (with or without optional initial slash)
+ # Not considered a tag. Shouldn't do any harm in browsers.
+ # (Tested with digits, with A syntax, with whitespace)
} else {
- # Legal tag.
-
- # Make i point to the first character inside the tag, after the tag name and any whitespace
- set i [expr { [lindex $match 1] + 1}]
-
- set attr_list [ad_parse_html_attributes_upvar html i]
+ # The tag was valid ... now let's see if it's on the allowed list.
+ set tagname [string tolower [string range $html [lindex $name_idx 0] [lindex $name_idx 1]]]
- set attr_count 0
- foreach attribute $attr_list {
- incr attr_count
+ if { ![info exists allowed_tag($tagname)] && ![info exists allowed_tag(*)] } {
+ # Nope, this was a naughty tag.
+ return "For security reasons we only accept the submission of HTML
+ containing the following tags: [join $allowed_tags_list " "].
+ You have a [string toupper $tagname] tag in there."
+ } else {
+ # Legal tag.
- lassign $attribute attr_name attr_value
-
- if { ![info exists allowed_attribute($attr_name)]
- && ![info exists allowed_attribute(*)] } {
- return "The attribute '$attr_name' is not allowed for $tagname tags"
- }
-
- if { [string tolower $attr_name] ne "style" } {
- if { [regexp {^\s*([^\s:]+):\/\/} $attr_value match protocol] } {
- if { ![info exists allowed_protocol([string tolower $protocol])]
- && ![info exists allowed_protocol(*)] } {
- return "Your URLs can only use these protocols: [join $allowed_protocols_list ", "].
+ # Make i point to the first character inside the tag, after the tag name and any whitespace
+ set i [expr { [lindex $match 1] + 1}]
+
+ set attr_list [ad_parse_html_attributes_upvar html i]
+
+ foreach attribute $attr_list {
+ lassign $attribute attr_name attr_value
+
+ if { ![info exists allowed_attribute($attr_name)]
+ && ![info exists allowed_attribute(*)] } {
+ return "The attribute '$attr_name' is not allowed for $tagname tags"
+ }
+
+ if { [string tolower $attr_name] ne "style" } {
+ if { [regexp {^\s*([^\s:]+):\/\/} $attr_value match protocol] } {
+ if { ![info exists allowed_protocol([string tolower $protocol])]
+ && ![info exists allowed_protocol(*)] } {
+ return "Your URLs can only use these protocols: [join $allowed_protocols_list ", "].
You have a '$protocol' protocol in there."
+ }
}
}
}
}
}
}
+ return {}
}
- return {}
-}
+ # This was created in order to pre-process some content to be fed
+ # to tDOM in ad_sanitize_html. In fact, even with its least picky
+ # behavior, tDOM cannot swallow whatever markup you give it. This
+ # proc might also be used in order to improve some OpenACS
+ # routines, like util_close_html_tags. As it has some limitations,
+ # this is left to future considerations.
+ ad_proc ad_dom_fix_html {
+ -html:required
+ {-marker "root"}
+ -dom:boolean
+ } {
+
+ Similar in spirit to the famous Tidy command line utility,
+ this proc takes a piece of possibly invalid markup and returns
+ a 'fixed' version where unopened tags have been closed and
+ attribute specifications have been normalized by transforming them
+ in the form attribute-name="attribute value". All
+ attributes with an invalid (non-alphanumeric) name will be
+ stripped.
+
+ Be aware that every comment and also the possibly present
+ DOCTYPE declaration will be stripped from the markup. Also,
+ most of tag's internal whitespace will be trimmed. This
+ behavior comes from the htmlparse library used in this
+ implementation.
+ @param html Markup to process
+ @param marker Root element use to enforce a single root of the
+ DOM tree.
+
+ @param dom When this flag is set, instead of returning markup,
+ the proc will return the tDOM object built during the
+ operation. Useful when the result should be used by tDOM
+ anyway, so we can avoid superfluous parsing.
-####################
-#
-# HTML -> Text
-#
-####################
+ @return markup or a tDOM document object if the -dom flag is
+ specified
-ad_proc -public ad_html_to_text {
- {-maxlen 70}
- {-showtags:boolean}
- {-no_format:boolean}
- html
-} {
- Returns a best-guess plain text version of an HTML fragment.
- Parses the HTML and does some simple formatting. The parser and
- formatting
- is pretty stupid, but it's better than nothing.
-
- @param maxlen the line length you want your output wrapped to.
- @param showtags causes any unknown (and uninterpreted) tags to get shown in the output.
- @param no_format causes hyperlink tags not to get listed at the end of the output.
+ @author Antonio Pisano
+
+ } {
+ if {[catch {package require struct}]} {
+ error "Package struct non found on the system"
+ }
+ if {[catch {package require htmlparse}]} {
+ error "Package htmlparse non found on the system"
+ }
+
+ set tree [::struct::tree]
- @author Lars Pind (lars@pinds.com)
- @author Aaron Swartz (aaron@swartzfam.com)
- @creation-date 19 July 2000
-} {
- set output(text) {}
- set output(linelen) 0
- set output(maxlen) $maxlen
- set output(pre) 0
- set output(p) 0
- set output(br) 0
- set output(space) 0
- set output(blockquote) 0
-
- set length [string length $html]
- set last_tag_end 0
+
+ catch {::htmlparse::tags destroy}
- # For showing the URL of links.
- set href_urls [list]
- set href_stack [list]
+ ::struct::stack ::htmlparse::tags
+ ::htmlparse::tags push root
+ $tree set root type root
- for { set i [string first < $html] } { $i != -1 } { set i [string first < $html $i] } {
- # append everything up to and not including the tag-opening <
- ad_html_to_text_put_text output [string range $html $last_tag_end $i-1]
+ ::htmlparse::parse \
+ -cmd [list ::htmlparse::2treeCallback $tree] \
+ -incvar errs $html
- # Check that:
- # - we're not past the end of the string
- # - and that the tag starts with either
- # - alpha or
- # - a slash, and then alpha
- # Otherwise, it's probably just a lone < character
- if { $i >= $length - 1 ||
- (![string is alpha [string index $html $i+1]]
- && [string index $html $i+1] ne "!"
- && ("/" ne [string index $html $i+1] ||
- ![string is alpha [string index $html $i+2]]))
- } {
- # Output the < and continue with next character
- ad_html_to_text_put_text output "<"
- set last_tag_end [incr i]
- continue
- } elseif {[string match "!--*" [string range $html $i+1 end]]} {
- # handle HTML comments, I can't beleive noone noticed this before.
- # this code maybe not be elegant but it works
-
- # find the closing comment tag.
- set comment_idx [string first "-->" $html $i]
- if {$comment_idx == -1} {
- # no comment close, escape
- set last_tag_end $i
- set i $comment_idx
- break
- }
- set i [expr {$comment_idx + 3}]
- set last_tag_end $i
-
- continue
- }
- # we're inside a tag now. Find the end of it
+ $tree walk root -order post n {
+ ::htmlparse::Reorder $tree $n
+ }
- # make i point to the char after the <
- incr i
- set tag_start $i
+ ::htmlparse::tags destroy
- set count 0
- while 1 {
- if {[incr count] > 3000 } {
- # JCD: the programming bug is that an unmatched < in the input runs off forever looking for
- # it's closing > and in some long text like program listings you can have lots of quotes
- # before you find that >
- error "There appears to be a programming bug in ad_html_to_text: We've entered an infinite loop."
- }
- # Find the positions of the first quote, apostrophe and greater-than sign.
- set quote_idx [string first \" $html $i]
- set apostrophe_idx [string first ' $html $i]
- set gt_idx [string first > $html $i]
- # If there is no greater-than sign, then the tag isn't closed.
- if { $gt_idx == -1 } {
- set i $length
- break
- }
+ set lmarker "<$marker>"
+ set rmarker ""
+ set doc [dom createDocument $marker]
+ set root [$doc documentElement]
+
+ set queue {}
+ lappend queue [list $root [$tree children [$tree children root]]]
+ while {$queue ne {}} {
+ lassign [lindex $queue 0] domparent treechildren
+ set queue [lrange $queue 1 end]
- # Find the first of the quote and the apostrophe
- if { $apostrophe_idx == -1 } {
- set string_delimiter_idx $quote_idx
- } else {
- if { $quote_idx == -1 } {
- set string_delimiter_idx $apostrophe_idx
+ foreach child $treechildren {
+ set type [$tree get $child type]
+ set data [$tree get $child data]
+ if {$type eq "PCDATA"} {
+ set el [$doc createTextNode $data]
} else {
- if { $apostrophe_idx < $quote_idx } {
- set string_delimiter_idx $apostrophe_idx
- } else {
- set string_delimiter_idx $quote_idx
+ set el [$doc createElement $type]
+
+ # parse element attributes
+ while {$data ne ""} {
+ set data [string trim $data]
+ # attribute with a value, optionally surrounded by double or single quotes
+ if {[regexp "^(\[^= \]+)=(\"\[^\"\]*\"|'\[^'\].*'|\[^ \]*)" $data m attname attvalue]} {
+ if {[string match "\"*\"" $attvalue] ||
+ [string match "'*'" $attvalue]} {
+ set attvalue [string range $attvalue 1 end-1]
+ }
+ # attribute with no value
+ } elseif {[regexp {^([^\s]+)} $data m attname]} {
+ set attvalue ""
+ } else {
+ error "Unrecoverable attribute spec in supplied markup"
+ }
+
+ # skip bogus attribute names
+ if {[string is alnum -strict $attname]} {
+ $el setAttribute $attname $attvalue
+ }
+
+ set data [string range $data [string length $m] end]
}
}
+
+ $domparent appendChild $el
+
+ set elchildren [$tree children $child]
+ if {$elchildren ne {}} {
+ lappend queue [list $el $elchildren]
+ }
}
- set string_delimiter [string index $html $string_delimiter_idx]
+ }
- # If the greater than sign appears before any of the string delimters, we've found the tag end.
- if { $gt_idx < $string_delimiter_idx || $string_delimiter_idx == -1 } {
- # we found the tag end
- set i $gt_idx
- break
- }
+ $tree destroy
- # Otherwise, we'll have to skip past the ending string delimiter
- set i [string first $string_delimiter $html [incr string_delimiter_idx]]
- if { $i == -1 } {
- # Missing string end delimiter
- set i $length
- break
+ if {$dom_p} {
+ return $doc
+ } else {
+ set html [$doc asHTML]
+ $doc delete
+ set html [string range $html [string length $lmarker] end-[string length $rmarker]]
+ }
+
+ return [string trim $html]
+ }
+
+ # Original purpose of this proc was to introduce a better way to
+ # enforce some HTML policies on the content submitted by the uses
+ # (e.g. forbid some tag/attribute like