Index: openacs-4/packages/acs-tcl/tcl/test/text-html-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/text-html-procs.tcl,v diff -u -N -r1.8 -r1.9 --- openacs-4/packages/acs-tcl/tcl/test/text-html-procs.tcl 5 Aug 2018 21:04:22 -0000 1.8 +++ openacs-4/packages/acs-tcl/tcl/test/text-html-procs.tcl 7 Sep 2018 00:30:14 -0000 1.9 @@ -219,7 +219,7 @@ } { - aa_log " ------------ Testing left pad ------------ " + aa_section "Testing left pad" set string [ad_generate_random_string] set length [expr {int(rand()*1000)}] @@ -234,7 +234,7 @@ aa_true " - Result is exactly $length long " {[string length $result] == $length} aa_true " - String is at right end " [regexp "^.*${string}\$" $result] - aa_log " ------------ Testing right pad ------------ " + aa_section "Testing right pad" set string [ad_generate_random_string] set length [expr {int(rand()*1000)}] @@ -251,7 +251,44 @@ } +aa_register_case \ + -cats {api smoke} \ + -procs {ad_html_qualify_links} \ + ad_html_qualify_links { + Test if ad_html_qualify_links is working as expected. + + @author Gustaf Neumann +} { + + aa_section "Testing without path" + + set rURL "relative/r.txt" + set aURL "/dotlrn/clubs/club1/mytext.docx" + set fqURL "https://openacs.org/doc/" + + set html [subst {
+ A relative URL relative/r.txt + An absolute URL mytext.docx + A fully qualified URL Documentation + }] + set result [ad_html_qualify_links -location {http://myhost/} $html] + + aa_true "result contains relative URL NOT expanded" {[string match *href=\"$rURL* $result]} + aa_true "result contains absolute URL location-prefixed" {[string match *http://myhost$aURL* $result]} + aa_true "result contains fully qualified URL" {[string match *$fqURL* $result]} + + aa_section "Testing with path" + + set pretty_link "/dotlrn/clubs/club2/uploads/mytext.docx" + set result [ad_html_qualify_links -location {http://myhost/} -path /somepath $html] + + aa_true "result contains relative URL expanded" {[string match */somepath/$rURL* $result]} + aa_true "result contains absolute URL location-prefixed" {[string match *http://myhost$aURL* $result]} + aa_true "result contains fully qualified URL" {[string match *$fqURL* $result]} + +} + # Local variables: # mode: tcl # tcl-indent-level: 4