Index: openacs-4/packages/xowiki/www/admin/test.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/www/admin/Attic/test.tcl,v diff -u -r1.41 -r1.42 --- openacs-4/packages/xowiki/www/admin/test.tcl 24 Dec 2017 12:51:38 -0000 1.41 +++ openacs-4/packages/xowiki/www/admin/test.tcl 3 Jan 2018 18:13:35 -0000 1.42 @@ -3,50 +3,51 @@ Object test test set passed 0 test set failed 0 -test proc case msg {ad_return_top_of_page "$msg

$msg

"} -test proc section msg {my reset; ns_write "

$msg

"} -test proc subsection msg {ns_write "

$msg

"} -test proc subsubsection msg {ns_write "
$msg
"} +test proc case msg {ad_return_top_of_page "$msg

$msg

"} +test proc section msg {my reset; ns_write "

$msg

"} +test proc subsection msg {ns_write "

$msg

"} +test proc subsubsection msg {ns_write "
$msg
"} test proc errmsg msg {my code "ERROR: [string map [list < {<} > {>}] $msg]
";test incr failed} test proc okmsg msg {ns_write "OK: $msg
"; test incr passed} test proc code msg {ns_write "
$msg
"} test proc hint msg {ns_write "$msg
"} test proc reset {} { array unset ::xotcl_cleanup - global af_parts af_key_name - array unset af_parts - array unset af_key_name + array unset ::af_parts + array unset ::af_key_name } test proc without_ns_form {cmd} { rename ::ns_queryget ::ns_queryget.orig rename ::ns_querygetall ::ns_querygetall.orig rename ::ad_returnredirect ::ad_returnredirect.orig - proc ::ns_queryget key { - #ns_log notice "queryget $key => [::xo::cc form_parameter $key {}]"; - ::xo::cc form_parameter $key "" + try { + proc ::ns_queryget key { + #ns_log notice "queryget $key => [::xo::cc form_parameter $key {}]"; + ::xo::cc form_parameter $key "" + } + proc ::ns_querygetall key { + #ns_log notice "querygetall $key => [list [::xo::cc form_parameter $key {}]]" + list [::xo::cc form_parameter $key {}] + } + proc ::ad_returnredirect url {::xo::cc returnredirect $url} + + try { + set r [uplevel $cmd] + } on error {errmsg} { + test code "error in command: $errmsg [info exists r]" + set r "" + } + } finally { + rename ::ns_queryget "" + rename ::ns_queryget.orig ::ns_queryget + rename ::ns_querygetall "" + rename ::ns_querygetall.orig ::ns_querygetall + rename ::ad_returnredirect "" + rename ::ad_returnredirect.orig ::ad_returnredirect } - proc ::ns_querygetall key { - #ns_log notice "querygetall $key => [list [::xo::cc form_parameter $key {}]]" - list [::xo::cc form_parameter $key {}] - } - proc ::ad_returnredirect url {::xo::cc returnredirect $url} - - ad_try { - set r [uplevel $cmd] - } on error errmsg} { - test code "error in command: $errmsg [info exists r]" - set r "" - } - rename ::ns_queryget "" - rename ::ns_queryget.orig ::ns_queryget - rename ::ns_querygetall "" - rename ::ns_querygetall.orig ::ns_querygetall - rename ::ad_returnredirect "" - rename ::ad_returnredirect.orig ::ad_returnredirect return $r } - proc ? {cmd expected {msg ""}} { set r [uplevel $cmd] if {$msg eq ""} {set msg $cmd} @@ -81,8 +82,8 @@ set tdom_version [package require tdom] if {$tdom_version < "0.8.0"} { ? {set x old} new "xowiki requires at least tDOM 0.8.0 (released Aug 2004), \ - the installed tDOM version is to old ($tdom_version).
   \ - Please Upgrade tDOM from: cvs -z3 -d:pserver:anonymous@cvs.tdom.org:/usr/local/pubcvs co tdom
" + the installed tDOM version is to old ($tdom_version).
   \ + Please Upgrade tDOM from: cvs -z3 -d:pserver:anonymous@cvs.tdom.org:/usr/local/pubcvs co tdom
" } else { ? {set x new} new "tdom version $tdom_version is ok" } @@ -102,7 +103,7 @@ site_node::delete -node_id $info(node_id) # remove the package instance apm_package_instance_delete $info(object_id) - + #test code [array get info] } @@ -381,7 +382,7 @@ ##################################################### set swas [xo::dc list get_swa "select grantee_id from acs_permissions \ - where object_id = -4 and privilege = 'admin'"] + where object_id = -4 and privilege = 'admin'"] ::xowiki::Package initialize -parameter $index_vuh_parms \ -package_id $info(package_id) \ @@ -539,22 +540,22 @@ -actual_query "m=edit" \ -user_id [lindex $swas 0] \ -form_parameter [subst { - form:id f1 - form:mode edit - formbutton:ok { OK } - __refreshing_p 0 + form:id f1 + form:mode edit + formbutton:ok { OK } + __refreshing_p 0 __confirmed_p 0 __new_p 0 - __key_signature {$signature} + __key_signature {$signature} __object_name en:hello - name en:hello - object_type ::xowiki::Page - text.format text/html - creator {{Gustaf Neumann}} + name en:hello + object_type ::xowiki::Page + text.format text/html + creator {{Gustaf Neumann}} description {{this is the description}} - text {{$text ... just testing ..
}} - nls_language en_US - folder_id $returned_folder_id + text {{$text ... just testing ..
}} + nls_language en_US + folder_id $returned_folder_id title {{$title - saved}} item_id $returned_item_id }] @@ -661,11 +662,11 @@ ? {::xowiki::FormPage filter_expression \ "_state=created|accepted|approved|tested|developed|deployed&&_assignee=123" &&} \ - {tcl {[lsearch -exact {created accepted approved tested developed deployed} [my property _state]] > -1&&[my property _assignee] eq {123}} h {} vars {} sql {{state in ('created','accepted','approved','tested','developed','deployed')} {assignee = '123'}}} filter_expr_where_1 + {tcl {[lsearch -exact {created accepted approved tested developed deployed} [:property _state]] > -1&&[:property _assignee] eq {123}} h {} vars {} sql {{state in ('created','accepted','approved','tested','developed','deployed')} {assignee = '123'}}} filter_expr_where_1 ? {::xowiki::FormPage filter_expression \ "_assignee<=123 && y>=123" &&} \ - {tcl {[my property _assignee] <= {123}&&[dict get $__ia y] >= {123}} h {} vars {y {}} sql {{assignee <= '123'}}} \ + {tcl {[:property _assignee] <= {123}&&[dict get $__ia y] >= {123}} h {} vars {y {}} sql {{assignee <= '123'}}} \ filter_expr_where_2 ? {::xowiki::FormPage filter_expression \ @@ -675,12 +676,12 @@ ? {::xowiki::FormPage filter_expression \ "_state=closed" ||} \ - {tcl {[my property _state] eq {closed}} h {} vars {} sql {{state = 'closed'}}} \ + {tcl {[:property _state] eq {closed}} h {} vars {} sql {{state = 'closed'}}} \ filter_expr_unless_1 ? {::xowiki::FormPage filter_expression \ "_state= closed|accepted || x = 1" ||} \ - {tcl {[lsearch -exact {closed accepted} [my property _state]] > -1||[dict get $__ia x] eq {1}} h x=>1 vars {x {}} sql {{state in ('closed','accepted')}}} \ + {tcl {[lsearch -exact {closed accepted} [:property _state]] > -1||[dict get $__ia x] eq {1}} h x=>1 vars {x {}} sql {{state in ('closed','accepted')}}} \ filter_expr_unless_1 @@ -697,21 +698,21 @@ # - typed links (glossary app)... important? # - interaction between PackagePath and folders (would be nice to inherit from folders, not packages) # -# Save this file in openacs-4/www/item-ref-test.tcl and run it via +# Save this file in openacs-4/www/item-ref-test.tcl and run it via # http://..../item-ref-test # # # "require_folder" and "require_page" are here just for testing proc require_folder {name parent_id package_id} { set item_id [::xo::db::CrClass lookup -name $name -parent_id $parent_id] - + if {$item_id == 0} { set form_id [::xowiki::Weblog instantiate_forms -forms en:folder.form -package_id $package_id] set f [$form_id create_form_page_instance \ - -name $name \ - -nls_language en_US \ - -default_variables [list title "Folder $name" parent_id $parent_id package_id $package_id]] + -name $name \ + -nls_language en_US \ + -default_variables [list title "Folder $name" parent_id $parent_id package_id $package_id]] $f save_new set item_id [$f item_id] } @@ -721,17 +722,17 @@ proc require_link {name parent_id package_id target_id} { set item_id [::xo::db::CrClass lookup -name $name -parent_id $parent_id] - + if {$item_id == 0} { set form_id [::xowiki::Weblog instantiate_forms -forms en:link.form -package_id $package_id] set target [::xo::db::CrClass get_instance_from_db -item_id $target_id] set item_ref [[$target package_id] external_name -parent_id [$target parent_id] [$target name]] set f [$form_id create_form_page_instance \ - -name $name \ - -nls_language en_US \ - -instance_attributes [list link $item_ref] \ - -default_variables [list title "Link $name" parent_id $parent_id package_id $package_id]] + -name $name \ + -nls_language en_US \ + -instance_attributes [list link $item_ref] \ + -default_variables [list title "Link $name" parent_id $parent_id package_id $package_id]] $f save_new set item_id [$f item_id] } @@ -742,7 +743,7 @@ proc require_page {name parent_id package_id {file_content ""}} { set item_id [::xo::db::CrClass lookup -name $name -parent_id $parent_id] if {$item_id == 0} { - if {$file_content eq ""} { + if {$file_content eq ""} { set f [::xowiki::Page new -name $name -description "" \ -parent_id $parent_id -package_id $package_id -text [list "Content of $name" text/html]] } else { @@ -766,6 +767,13 @@ #some test cases ::xowiki::Package initialize -url /$instance_name/ +set expected_locale "" +foreach nls_language [lang::system::get_locales] { + if {[string range $nls_language 0 1] eq "de"} { + set expected_locale $nls_language + } +} + # We use destroy_on_cleanup here although the object is explicitly # destroyed later. However, if some test bails out with an error, # the destroy might not be reached @@ -816,7 +824,7 @@ set test [label "item_ref" "existing topfolder" $l] array set "" [p item_ref -default_lang en -parent_id $folder_id $l] ? {expr {$(link_type) eq "link" && $(prefix) eq "" && $(stripped_name) eq "f1" - && $(form) eq "en:folder.form" + && $(form) eq "en:folder.form" && $(parent_id) eq $folder_id && $(item_id) == $f1_id}} 1 "\n$test:\n [array get {}]\n " set l "de:parentpage" @@ -909,7 +917,7 @@ set l "/" ;# stripped name will be the name of the root folder set test [label "item_ref" "just slash" $l] array set "" [p item_ref -default_lang de -parent_id $folder_id $l] - ? {expr {$(link_type) eq "folder" && $(prefix) eq "" + ? {expr {$(link_type) eq "folder" && $(prefix) eq "" && $(parent_id) == -100 && $(item_id) == $folder_id}} 1 "\n$test:\n [array get {}]\n " @@ -955,7 +963,7 @@ set l "./" ;# stripped name will be the name of the root folder set test [label "item_ref" "dot with slash, relative" $l] array set "" [p item_ref -default_lang de -parent_id $folder_id $l] - ? {expr {$(link_type) eq "folder" && $(prefix) eq "" + ? {expr {$(link_type) eq "folder" && $(prefix) eq "" && $(parent_id) == -100 && $(item_id) == $folder_id}} 1 "\n$test:\n [array get {}]\n " ################################## @@ -965,7 +973,7 @@ set l "." ;# stripped name will be the name of the root folder, omit from test set test [label "item_ref" "dot with slash, relative" $l] array set "" [p item_ref -default_lang de -parent_id $folder_id $l] - ? {expr {$(link_type) eq "folder" && $(prefix) eq "" + ? {expr {$(link_type) eq "folder" && $(prefix) eq "" && $(parent_id) eq -100 && $(item_id) == $folder_id}} 1 "\n$test:\n [array get {}]\n " set l "./f1/." @@ -1177,7 +1185,7 @@ set l "parentpage1" set test [label "link" "not existing simple page" $l] set link [p create_link $l] -? {$link render} [subst -nocommands { parentpage1}] "\n$test\n " +? {$link render} [subst -nocommands { parentpage1}] "\n$test\n " set l "parentpage#a" set test [label "link" "existing simple with anchor" $l] @@ -1265,7 +1273,7 @@ ? {$l5 pretty_link} "/XOWIKI-TEST/link5" ? {$l5 pretty_link -download true} "/XOWIKI-TEST/download/file/link5" - test section "item info from pretty links" + test section "item info from pretty links" set l [$f1 pretty_link] set test [label "url" "topfolder" $l] @@ -1275,12 +1283,12 @@ set l [$f2 pretty_link] set test [label "url" "folder under topfolder" $l] array set "" [$package_id item_info_from_url $l] - ? {expr {$(item_id) == $f3_id && $(stripped_name) eq "f3"}} 1 "\n$test:\n [array get {}]\n " + ? {expr {$(item_id) == $f3_id && $(stripped_name) eq "f3"}} 1 "\n$test:\n [array get {}]\n " set l [$f3 pretty_link] set test [label "url" "subsubfolder" $l] array set "" [$package_id item_info_from_url $l] - ? {expr {$(item_id) == $subf3_id && $(stripped_name) eq "subf3"}} 1 "\n$test:\n [array get {}]\n " + ? {expr {$(item_id) == $subf3_id && $(stripped_name) eq "subf3"}} 1 "\n$test:\n [array get {}]\n " set l [$p1 pretty_link] set test [label "url" "toppage" $l] @@ -1301,92 +1309,92 @@ set test [label "url" "toplevel en page" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $enpage_id && $(stripped_name) eq "page" - && $(name) eq "en:page"}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "en:page"}} 1 "\n$test:\n [array get {}]\n " set l [$p5 pretty_link] set test [label "url" "en page under subfolder" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $f3page_id && $(stripped_name) eq "page" - && $(name) eq "en:page"}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "en:page"}} 1 "\n$test:\n [array get {}]\n " # image links set l [$i1 pretty_link] set test [label "url" "toplevel image" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $image_id && $(stripped_name) eq "image.png" - && $(name) eq "file:image.png"}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "file:image.png"}} 1 "\n$test:\n [array get {}]\n " set l [$i2 pretty_link] set test [label "url" "toplevel image" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $subimage_id && $(stripped_name) eq "image2.png" - && $(name) eq "file:image2.png"}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "file:image2.png"}} 1 "\n$test:\n [array get {}]\n " set l [$i3 pretty_link] set test [label "url" "toplevel image" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $childimage_id && $(stripped_name) eq "image3.png" - && $(name) eq "file:image3.png" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "file:image3.png" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " - + # links - + set l [$l1 pretty_link] set test [label "url" "toplevel link to page" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $pagelink_id && $(stripped_name) eq "link1" - && $(name) eq "link1" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "link1" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " set l [$l2 pretty_link] set test [label "url" "toplevel link to folder" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $folderlink_id && $(stripped_name) eq "link2" - && $(name) eq "link2" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "link2" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " set l [$l3 pretty_link] set test [label "url" "toplevel link to page under folder" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $subpagelink_id && $(stripped_name) eq "link3" - && $(name) eq "link3" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "link3" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " set l [$l4 pretty_link] set test [label "url" "toplevel link to folder under folder" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $subfolderlink_id && $(stripped_name) eq "link4" - && $(name) eq "link4" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "link4" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " set l [$l5 pretty_link] set test [label "url" "toplevel link to image under folder" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $subimagelink_id && $(stripped_name) eq "link5" - && $(name) eq "link5" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "link5" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n " ######################################################## test section "item info from variations of pretty links" -######################################################## +######################################################## # download set l /XOWIKI-TEST/download/file/image.png set test [label "url" "toplevel image download" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $image_id && $(stripped_name) eq "image.png" - && $(name) eq "file:image.png" && $(method) eq "download"}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "file:image.png" && $(method) eq "download"}} 1 "\n$test:\n [array get {}]\n " # download via link #set l /XOWIKI-TEST/download/file/link5 #set test [label "url" "toplevel image download" $l] #array set "" [$package_id item_info_from_url $l] #test hint "

found $(item_id) should be $subimagelink_id" # ? {expr {$(item_id) == $subimagelink_id && $(stripped_name) eq "link5" - # && $(name) eq "file:link5" && $(method) eq "download"}} 1 "\n$test:\n [array get {}]\n " + # && $(name) eq "file:link5" && $(method) eq "download"}} 1 "\n$test:\n [array get {}]\n " # tag link set l /XOWIKI-TEST/tag/a set test [label "url" "tag query" $l] array set "" [$package_id item_info_from_url -default_lang de $l] ? {expr {$(item_id) != 0 && $(stripped_name) eq "weblog" - && $(name) eq "en:weblog" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n" + && $(name) eq "en:weblog" && $(method) eq ""}} 1 "\n$test:\n [array get {}]\n" # missing: tag links to subdirectories # url without default lang @@ -1408,7 +1416,7 @@ ############################################# -test section "item info via links to folders" +test section "item info via links to folders" ############################################# # reference pages over links to folders @@ -1417,28 +1425,28 @@ set test [label "url" "reference page over links to folder default-lang" $l] array set "" [$package_id item_info_from_url -default_lang de $l] ? {expr {$(item_id) == $testpage_id && $(stripped_name) eq "testpage" - && $(name) eq "de:testpage"}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "de:testpage"}} 1 "\n$test:\n [array get {}]\n " set l /XOWIKI-TEST/link2/de:testpage set test [label "url" "reference page over links to folder direct name" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $testpage_id && $(stripped_name) eq "testpage" - && $(name) eq "de:testpage"}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "de:testpage"}} 1 "\n$test:\n [array get {}]\n " set l /XOWIKI-TEST/download/file/link2/image2.png set test [label "url" "reference download image over links to folder" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $subimage_id && $(stripped_name) eq "image2.png" - && $(name) eq "file:image2.png"}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "file:image2.png"}} 1 "\n$test:\n [array get {}]\n " set l /XOWIKI-TEST/link2/f3/page set test [label "url" "path contains link and references finally page" $l] array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $f3page_id && $(stripped_name) eq "page" - && $(name) eq "en:page"}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "en:page"}} 1 "\n$test:\n [array get {}]\n " - #test section "inherited pages" + #test section "inherited pages" # link to site-wide page @@ -1451,8 +1459,8 @@ # link to dir in other package ########################## -test section "Form Fields" -########################## +test section "Form Fields" +########################## # Create dummy object with a minimal setup to be used like a page set o [::xotcl::Object new -destroy_on_cleanup] @@ -1467,20 +1475,20 @@ "name with help_text" set f0 [$o create_raw_form_field -name test \ - -slot ::xowiki::Page::slot::name -spec inform] + -slot ::xowiki::Page::slot::name -spec inform] ? {$f0 asWidgetSpec} \ {text(inform) {label {#xowiki.Page-name#}} {html {id F.dummy.test }} {help_text {Shortname to identify an entry within a folder, typically lowercase characters}}} \ "name with help_text + inform" set f0 [$o create_raw_form_field -name test \ - -slot ::xowiki::Page::slot::name -spec optional] + -slot ::xowiki::Page::slot::name -spec optional] ? {$f0 asWidgetSpec} \ {text,optional {label {#xowiki.Page-name#}} {html {maxlength 400 id F.dummy.test size 80 }} {help_text {Shortname to identify an entry within a folder, typically lowercase characters}}} \ "name with help_text + optional" set f1 [$o create_raw_form_field -name test \ - -slot ::xowiki::Page::slot::description \ - -spec "textarea,cols=80,rows=2"] + -slot ::xowiki::Page::slot::description \ + -spec "textarea,cols=80,rows=2"] ? {$f1 asWidgetSpec} \ {text(textarea),nospell,optional {label {#xowiki.Page-description#}} {html {cols 80 id F.dummy.test rows 2 }} } \ "textarea,cols=80,rows=2" @@ -1498,15 +1506,15 @@ ? {$f3 asWidgetSpec} \ {date,optional {label {#xowiki.PodcastItem-pub_date#}} {html {id F.dummy.test }} {format {YYYY MM DD HH24 MI}} } \ {date with format} - + ns_write "

Tests passed: [test set passed]
Tests failed: [test set failed]
Tests Time: [t1 diff -start]ms
-" +" # Local variables: # mode: tcl