Index: openacs-4/packages/xowiki/tcl/form-field-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/tcl/form-field-procs.tcl,v diff -u -N -r1.183 -r1.184 --- openacs-4/packages/xowiki/tcl/form-field-procs.tcl 13 Jul 2010 11:22:23 -0000 1.183 +++ openacs-4/packages/xowiki/tcl/form-field-procs.tcl 13 Jul 2010 18:11:04 -0000 1.184 @@ -2127,59 +2127,32 @@ # note that the includelet "include" can be used for implementing symbolic links # to other xowiki pages. Class include -superclass text -parameter { - } -extend_slot validator link - - include instproc convert_to_internal {} { - my instvar object value - - set props [$object compute_link_properties $value] - $object set_property -new 1 [my name] $props - } - include instproc convert_to_external {value} { - if {$value ne ""} { - if {[catch {array set "" $value}]} {return $value} - return $(item_ref) - } - return "" - } - + include instproc pretty_value {v} { if {$v eq ""} { return $v } - if {[catch {array set "" $v}]} { - my log "warning: strange value for field [my name] '$v'" - return $v - } - my instvar object - if {$(item_id) && [info command $(item_id)] ne ""} { - set page $(item_id) - } else { - set page [[$object package_id] get_page_from_item_ref \ - -default_lang [$object lang] \ - -parent_id [$object parent_id] \ - $(item_ref)] - } - #my msg page=$page - if {$page eq ""} { + my instvar object + set item_id [$object get_property_from_link_page item_id] + if {$item_id == 0} { # Here, we could call "::xowiki::Link render" to offer the user means # to create the entry like with [[..]], if he has sufficent permissions...; # when $(package_id) is 0, the referenced package could not be # resolved return "Cannot resolve symbolic link '$v'" } - $object lappend references [list [$page item_id] $(link_type)] + set link_type [$object get_property_from_link_page link_type] + $object lappend references [list $item_id $link_type] - #my msg "could switch from [$page item_id] [$page package_id] to [$object item_id] [$object package_id]" # # resetting esp. the item-id is dangerous. Therefore we reset it immediately after the rendering # - $page set_resolve_context \ + $item_id set_resolve_context \ -package_id [$object package_id] -parent_id [$object parent_id] \ -item_id [$object item_id] - set html [$page render] + set html [$item_id render] #my msg "reset resolve-context" - $page reset_resolve_context + $item_id reset_resolve_context return $html } 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 -N -r1.231 -r1.232 --- openacs-4/packages/xowiki/tcl/package-procs.tcl 13 Jul 2010 11:22:23 -0000 1.231 +++ openacs-4/packages/xowiki/tcl/package-procs.tcl 13 Jul 2010 18:11:04 -0000 1.232 @@ -899,8 +899,8 @@ # Page not found so far. Is the parent-page a folder-link? # ::xo::db::CrClass get_instance_from_db -item_id $parent_id - if {[$parent_id is_link_page] && [$parent_id is_folder_page]} { - set target [$parent_id get_page_from_link_page] + if {$parent_id > 0 && [$parent_id is_link_page] && [$parent_id is_folder_page]} { + set target [$parent_id get_target_from_link_page] #my log "LINK LOOKUP from target-package [$target package_id] source package $(package_id)" return [[$target package_id] lookup \ -use_package_path $use_package_path \ @@ -1226,7 +1226,7 @@ # check link (todo should happen in package->lookup?) ::xo::db::CrClass get_instance_from_db -item_id $(parent_id) if {[$(parent_id) is_link_page] && [$(parent_id) is_folder_page]} { - set target [$(parent_id) get_page_from_link_page] + set target [$(parent_id) get_target_from_link_page] #$target set_resolve_context -package_id [my id] -parent_id $(parent_id) #my msg "LINK prefixed LOOKUP from target-package [$target package_id] source package [my id]" array set "" [[$target package_id] prefixed_lookup -parent_id [$target item_id] \ 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 -N -r1.420 -r1.421 --- openacs-4/packages/xowiki/tcl/xowiki-procs.tcl 13 Jul 2010 11:22:23 -0000 1.420 +++ openacs-4/packages/xowiki/tcl/xowiki-procs.tcl 13 Jul 2010 18:11:04 -0000 1.421 @@ -913,14 +913,22 @@ # Page instproc get_property_from_link_page {property {default ""}} { if {![my is_link_page]} {return $default} - set link [my property link] - if {$link eq "" || [llength $link] < 2} {return $default} - array set "" $link - if {[info exists ($property)]} {return $($property)} + set item_ref [my property link] + + # TODO we could save some double-fetch by collecing in + # get_form_entries via item-ids, not via new-objects + ::xo::db::CrClass get_instance_from_db -item_id [my item_id] + + set props [::xo::cc cache [list [my item_id] compute_link_properties $item_ref]] + array set "" $props + if {[info exists ($property)]} { + #[my item_id] msg "prop $property ==> $($property)" + return $($property) + } return $default } - Page instproc get_page_from_link_page {} { + Page instproc get_target_from_link_page {} { 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] @@ -932,31 +940,12 @@ return $target } - FormPage instproc get_verified_link_type_from_link_page {} { - set link_type [my get_property_from_link_page link_type "unresolved"] - if {1 || $link_type eq "unresolved"} { - # to to resolve again - set props [my compute_link_properties [my get_property_from_link_page item_ref]] - array set "" $props - # if link_type is now unresolved, update the link properties - if {$(link_type) ne $link_type} { - set link_type $(link_type) - my set_property -new 1 link $props - my save - my msg "rewritten" - } - } - return $link_type - } - FormPage instproc compute_link_properties {item_ref} { my instvar package_id set page [$package_id get_page_from_item_ref \ -default_lang [my lang] \ -parent_id [my parent_id] \ $item_ref] - #my msg "$item_ref => $page, o package_id [my package_id] t [$page object_id]" - if {$page ne ""} { set item_id [$page item_id] set link_type [expr {[$page is_folder_page] ? "folder_link" : "link"}] @@ -966,6 +955,7 @@ set link_type "unresolved" set cross_package 0 } + #my msg [list item_ref $item_ref item_id $item_id link_type $link_type cross_package $cross_package] return [list item_ref $item_ref item_id $item_id link_type $link_type cross_package $cross_package] } @@ -1019,7 +1009,7 @@ #my msg "$name / '$stripped_name'" # prepend the language prefix only, if the entry is not empty if {$stripped_name ne ""} { - if {[my is_folder_page]} { + if {[my is_folder_page] || [my is_link_page]} { # # Do not add a language prefix to folder pages # @@ -3140,7 +3130,7 @@ return [list text "" is_richtext true] } en:link.form { - set link_type [my get_verified_link_type_from_link_page] + set link_type [my get_property_from_link_page link_type "unresolved"] set link_icon "http://www.ejoe.at/typo3/sysext/rtehtmlarea/res/accessibilityicons/img/internal_link.gif" if {$link_type eq "unresolved"} { return [list text " \