Index: openacs-4/packages/xowiki/tcl/package-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/tcl/package-procs.tcl,v diff -u -r1.232 -r1.233 --- openacs-4/packages/xowiki/tcl/package-procs.tcl 13 Jul 2010 18:11:04 -0000 1.232 +++ openacs-4/packages/xowiki/tcl/package-procs.tcl 14 Jul 2010 09:17:19 -0000 1.233 @@ -149,7 +149,7 @@ # try without a prefix #set p [::xo::db::CrClass lookup -name $parent -parent_id $parent_id] set p [my lookup -name $parent -parent_id $parent_id] - #my log "check plain '$parent' returned $p" + #my msg "path '$path' check '$parent' $parent_id returns $p" if {$p == 0} { # pages are stored with a lang prefix @@ -637,11 +637,19 @@ return "" } } - + Package array set delegate_link_to_target { + csv-dump 1 download 1 list 1 + } Package instproc invoke {-method {-error_template error-template} {-batch_mode 0}} { set page [my resolve_page [my set object] method] #my log "--r resolve_page => $page" if {$page ne ""} { + if {[$page is_link_page] && [[self class] exists delegate_link_to_target($method)]} { + # if the target is a link, we may want to call the method on the target + set target [$page get_target_from_link_page] + #my msg "delegate $method from $page [$page name] to $target [$target name]" + if {$target ne ""} {set page $target} + } if {[$page procsearch $method] eq ""} { return [my error_msg "Method '$method' is not defined for this object"] } else { @@ -737,7 +745,7 @@ # # second, resolve object level # - #my msg "call item_info from url" + #my msg "call item_info_from url" array set "" [my item_info_from_url -with_package_prefix false -default_lang $lang $object] if {$(item_id) ne 0} { @@ -854,8 +862,8 @@ # @return item-ref info # set item_id 0 - if {$lang eq $default_lang} { - # try a direct lookup + if {$lang eq $default_lang || $lang eq "file"} { + # try a direct lookup; ($lang eq "file" needed for links to files) set item_id [::xo::db::CrClass lookup -name $stripped_name -parent_id $parent_id] if {$item_id != 0} { set name $stripped_name @@ -1197,7 +1205,7 @@ -lang $(lang) -path $stripped_url \ -parent_id [my folder_id] \ parent (stripped_name)] - #my msg "get_parent_and_name '$stripped_url' returns '$(stripped_name)'" + #my msg "get_parent_and_name '$stripped_url' returns [array get {}]" if {![regexp {^(download)/(.+)$} $(lang) _ (method) (lang)]} { set (method) "" Index: openacs-4/packages/xowiki/tcl/xowiki-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/tcl/xowiki-procs.tcl,v diff -u -r1.421 -r1.422 --- openacs-4/packages/xowiki/tcl/xowiki-procs.tcl 13 Jul 2010 18:11:04 -0000 1.421 +++ openacs-4/packages/xowiki/tcl/xowiki-procs.tcl 14 Jul 2010 09:17:19 -0000 1.422 @@ -892,7 +892,7 @@ set page_template_name [[my page_template] name] if {$page_template_name eq "en:folder.form"} {return 1} if {$include_folder_links && $page_template_name eq "en:link.form"} { - set link_type [my get_property_from_link_page link_type ""] + set link_type [my get_property_from_link_page link_type] return [expr {$link_type eq "folder_link"}] } return 0 @@ -928,7 +928,17 @@ return $default } - Page instproc get_target_from_link_page {} { + Page instproc get_target_from_link_page {{-depth 10}} { + # + # Dereference link and return target object of the + # link. Dereferencing happens up to a maximal depth to avoid loop + # in circular link structures. If this method is called with e.g. + # {-depth 1} and the link (actual object) points to some link2, + # the link2 is returned. + # + # @param depth maximal dereferencing depth + # @return target object or empty + # set item_id [my get_property_from_link_page item_id 0] if {$item_id == 0} {return ""} set target [::xo::db::CrClass get_instance_from_db -item_id $item_id] @@ -937,6 +947,9 @@ ::xowiki::Package require $target_package_id #::xowiki::Package initialize -package_id $target_package_id -init_url false -keep_cc true } + if {$depth > 1 && [$target is_link_page]} { + set target [my get_target_from_link_page -count [expr {$depth - 1}]] + } return $target } Index: openacs-4/packages/xowiki/tcl/xowiki-www-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/tcl/xowiki-www-procs.tcl,v diff -u -r1.283 -r1.284 --- openacs-4/packages/xowiki/tcl/xowiki-www-procs.tcl 12 Jul 2010 15:13:19 -0000 1.283 +++ openacs-4/packages/xowiki/tcl/xowiki-www-procs.tcl 14 Jul 2010 09:17:19 -0000 1.284 @@ -421,7 +421,6 @@ # # externally callable method: download # - File instproc download {} { my instvar mime_type package_id $package_id set mime_type $mime_type @@ -438,6 +437,22 @@ } # + # We handle delegation to target for most methods in + # Package->invoke. Otherwise, we would have to implement several + # forwarder methods like the following: + # + +# FormPage instproc download {} { +# # If there is a link to a file, it can be downloaded as well +# set target [my get_target_from_link_page] +# if {$target ne "" && [$target istype ::xowiki::File]} { +# $target download +# } else { +# [my package_id] error_msg "Method 'download' not implemented for this kind of object" +# } +# } + + # # helper methods for externally callable method: edit # 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.28 -r1.29 --- openacs-4/packages/xowiki/www/admin/test.tcl 12 Jul 2010 15:13:19 -0000 1.28 +++ openacs-4/packages/xowiki/www/admin/test.tcl 14 Jul 2010 09:17:19 -0000 1.29 @@ -539,9 +539,13 @@ set p [::xowiki::Page info instances] ? {llength $p} 1 "expect only one page instance" + if {[llength $p] == 1} { ? {$p set title} {Hello World- V.2 - saved} "saved title is ok" ? {lindex [$p set text] 0} {Hello [[Wiki]] World. ... just testing ..
} "saved text is ok" +} else { + test code [::xowiki::Page info instances] + foreach p [::xowiki::Page info instances] {test code "$p [$p serialize]"} } ? {string first Error $content} -1 "page contains no error" @@ -669,22 +673,20 @@ 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 link_type [expr {[$target is_folder_page] ? "folder_link" : "link"}] - set cross_package [expr {$package_id != [$target package_id]}] - set value [list item_ref [$target name] item_id $target_id link_type $link_type cross_package $cross_package] - set f [$form_id create_form_page_instance \ -name $name \ -nls_language en_US \ - -instance_attributes [list link $value] \ + -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] } test hint " $name => $item_id\n" return $item_id } + 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} { @@ -739,11 +741,11 @@ set subimage_id [require_page file:image2.png $f1_id $package_id $base64] set childimage_id [require_page file:image3.png $parentpage_id $package_id $base64] - set pagelink_id [require_link de:link1 $folder_id $package_id $parentpage_id] - set folderlink_id [require_link de:link2 $folder_id $package_id $f1_id] - set subpagelink_id [require_link de:link3 $folder_id $package_id $testpage_id] - set subfolderlink_id [require_link de:link4 $folder_id $package_id $f3_id] - set subimagelink_id [require_link de:link5 $folder_id $package_id $subimage_id] + set pagelink_id [require_link link1 $folder_id $package_id $parentpage_id] + set folderlink_id [require_link link2 $folder_id $package_id $f1_id] + set subpagelink_id [require_link link3 $folder_id $package_id $testpage_id] + set subfolderlink_id [require_link link4 $folder_id $package_id $f3_id] + set subimagelink_id [require_link link5 $folder_id $package_id $subimage_id] ################################ @@ -1112,6 +1114,7 @@ ? {$link render} {} "\n$test\n " ? {p array get lang_links} [subst -nocommands {found {{de}}}] "\n$test links\n " + p destroy ############################################ test section "page properties" @@ -1136,8 +1139,6 @@ set l4 [::xo::db::CrClass get_instance_from_db -item_id $subfolderlink_id] set l5 [::xo::db::CrClass get_instance_from_db -item_id $subimagelink_id] - - ? {$f1 is_folder_page} 1 ? {$f2 is_folder_page} 1 ? {$f3 is_folder_page} 1 @@ -1168,11 +1169,12 @@ ? {$i2 pretty_link} "/XOWIKI-TEST/file/f1/image2.png" ? {$i3 pretty_link} "/XOWIKI-TEST/file/de:parentpage/image3.png" - ? {$l1 pretty_link} "/XOWIKI-TEST/de/link1" - ? {$l2 pretty_link} "/XOWIKI-TEST/de/link2" - ? {$l3 pretty_link} "/XOWIKI-TEST/de/link3" - ? {$l4 pretty_link} "/XOWIKI-TEST/de/link4" - ? {$l5 pretty_link} "/XOWIKI-TEST/de/link5" + ? {$l1 pretty_link} "/XOWIKI-TEST/link1" + ? {$l2 pretty_link} "/XOWIKI-TEST/link2" + ? {$l3 pretty_link} "/XOWIKI-TEST/link3" + ? {$l4 pretty_link} "/XOWIKI-TEST/link4" + ? {$l5 pretty_link} "/XOWIKI-TEST/link5" + ? {$l5 pretty_link -download true} "/XOWIKI-TEST/download/file/link5" test section "item info from pretty links" @@ -1245,31 +1247,31 @@ 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 "de: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 "de: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 "de: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 "de: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 "de: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" @@ -1282,11 +1284,11 @@ && $(name) eq "file:image.png" && $(method) eq "download"}} 1 "\n$test:\n [array get {}]\n " # download via link - set l /XOWIKI-TEST/download/de/link5 + set l /XOWIKI-TEST/download/file/link5 set test [label "url" "toplevel image download" $l] - array set "" [$package_id item_info_from_url -default_lang de $l] + array set "" [$package_id item_info_from_url $l] ? {expr {$(item_id) == $subimagelink_id && $(stripped_name) eq "link5" - && $(name) eq "de:link5" && $(method) eq "download"}} 1 "\n$test:\n [array get {}]\n " + && $(name) eq "link5" && $(method) eq "download"}} 1 "\n$test:\n [array get {}]\n " # tag link set l /XOWIKI-TEST/tag/a @@ -1317,25 +1319,25 @@ test section "item info via links to folders" # reference pages over links to folders - set l /XOWIKI-TEST/de:link2/testpage + set l /XOWIKI-TEST/link2/testpage 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 " - set l /XOWIKI-TEST/de:link2/de:testpage + 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 " - set l /XOWIKI-TEST/download/file/de:link2/image2.png + 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 " - set l /XOWIKI-TEST/de:link2/f3/page + 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"