Valid Installed Bindings
+ +-
+
- None +
- @valid_installed_binding.impl_id@ + @valid_installed_binding.impl_name@ + (@valid_installed_binding.impl_owner_name@) + [Uninstall] +
-
+
- Create application group +
- Create segment "Subsite Users" +
- Create relational constraint to make subsite registration + require supersite registration. +
+ @author Don Baccus (dhogaza@pacifier.com)
+ @creation-date 2003-03-05
- NOTE: this proc might not work without a connection (i.e.,
- [ad_conn isconnected]==1). I haven't tested it without a connection,
- but I think the code would work right now (assuming the caller passes
- in a valid package_id). However, in the future, this proc may redirect
- the administrator to a configuration "wizard" in case we need or want
- some input from the admin to properly configure the subsite.
+} {
- @author Oumi Mehrotra (oumi@arsdigita.com)
- @creation-date 2000-02-05
+ if { [empty_string_p [application_group::group_id_from_package_id -no_complain -package_id $package_id]] } {
- @param package_id The package_id of the subsite application instance
- to configure. If package_id is not specified, then
- [ad_conn package_id] will be used.
+ set subsite_name [db_string subsite_name_query {}]
- } {
- if {![configured_p -package_id $package_id]} {
- configure -package_id $package_id
- }
+ set truncated_subsite_name [string range $subsite_name 0 89]
- }
+ db_transaction {
+ # Create subsite application group
+ set group_name "$truncated_subsite_name Parties"
+ set subsite_group_id [application_group::new \
+ -package_id $package_id \
+ -group_name $group_name]
- ad_proc subsite::configured_p {
- {-package_id ""}
- } {
- Determines whether a subsite has been configured. Returns 1 if
- configured, or 0 otherwise. Right now, a subsite is considered
- to be configured if its application group exists. In the future,
- we may store an explicit "configured_p" setting in the DB.
+ # Create segment of registered users
+ set segment_name "$truncated_subsite_name Members"
+ set segment_id [rel_segments_new $subsite_group_id membership_rel $segment_name]
- @author Oumi Mehrotra (oumi@arsdigita.com)
- @creation-date 2000-02-05
+ # Create a constraint that says "to be a member of this subsite you must be a member
+ # of the parent subsite.
- @param package_id The package_id of the subsite application instance
- to configure. If package_id is not specified, then
- [ad_conn package_id] will be used.
- } {
- if {[empty_string_p [application_group::group_id_from_package_id \
- -no_complain \
- -package_id $package_id]]} {
- return 0
- }
- return 1
- }
+ db_1row parent_subsite_query {}
+ set constraint_name "Members of [string range $subsite_name 0 30] must be members of [string range $supersite_name 0 30]"
+ set user_id [ad_conn user_id]
+ set creation_ip [ad_conn peeraddr]
+ db_exec_plsql add_constraint {}
-
-
- ad_proc subsite::configure {
- {-package_id ""}
- } {
- Configures a subsite. This involves 3 steps:
-
-
-
-
- Create application group -
- Create segment "Subsite Users" -
- Create relational constraint to make subsite registration - require supersite registration. -
[ad_conn package_id] will be used.
-
- } {
-
- if {[ad_conn isconnected]} {
- if {[empty_string_p $package_id]} {
- set package_id [ad_conn package_id]
- }
- }
-
- if {[empty_string_p $package_id]} {
- error "subsite::configure - package_id not specified"
- }
-
- set subsite_name [db_string subsite_name_query {
- select instance_name
- from apm_packages
- where package_id = :package_id
- }]
-
- set truncated_subsite_name [string range $subsite_name 0 89]
-
- db_transaction {
-
- # Create subsite application group
- set group_name "$truncated_subsite_name Parties"
- set subsite_group_id [application_group::new \
- -package_id $package_id \
- -group_name $group_name]
-
- # Create segment of registered users
- set segment_name "$truncated_subsite_name Members"
- set segment_id [rel_segments_new $subsite_group_id membership_rel $segment_name]
-
- # Create constraint that says "to be a member of this
- # subsite, you have to be a member of the parent subsite"
-
- set supersite_group_id ""
-
- db_0or1row parent_subsite_query {
- select m.group_id as supersite_group_id,
- p.instance_name as supersite_name
- from application_group_element_map m,
- apm_packages p
- where p.package_id = m.package_id
- and container_id = group_id
- and element_id = :subsite_group_id
- and rel_type = 'composition_rel'
- }
-
- # First get parent application group's id and instance name
- if { ![empty_string_p $supersite_group_id] } {
-
- set constraint_name "Members of [string range $subsite_name 0 30] must be members of [string range $supersite_name 0 30]"
-
- if {[ad_conn isconnected]} {
- set user_id [ad_conn user_id]
- set creation_ip [ad_conn peeraddr]
- } else {
- set user_id ""
- set creation_ip ""
- }
-
- set constraint_id [db_exec_plsql add_constraint {
- BEGIN
- :1 := rel_constraint.new(
- constraint_name => :constraint_name,
- rel_segment => :segment_id,
- rel_side => 'two',
- required_rel_segment => rel_segment.get(:supersite_group_id, 'membership_rel'),
- creation_user => :user_id,
- creation_ip => :creation_ip
- );
- END;
- }]
- }
- }
-
+ }
}
+}
+ad_proc -public subsite::before_uninstantiate {
+ {-package_id:required}
+} {
+ Delete the application group associated with this subsite.
+} {
+ application_group::delete -group_id [application_group::group_id_from_package_id -package_id $package_id]
+}
+
ad_proc -private subsite::instance_name_exists_p {
node_id
instance_name
@@ -202,24 +95,24 @@
}]
}
-
ad_proc -public subsite::auto_mount_application {
{ -instance_name "" }
{ -pretty_name "" }
{ -node_id "" }
package_key
} {
Mounts a new instance of the application specified by package_key
- beneath node_id. This proc makes sure that the instance_name (the
+ beneath node_id. This proc makes sure that the instance_name (the
name of the new node) is unique before invoking site_node::instantiate_and_mount.
-
+
+
@author Michael Bryzek (mbryzek@arsdigita.com)
@creation-date 2001-02-28
@param instance_name The name to use for the url in the
site-map. Defaults to the package_key plus a possible digit to
serve as a unique identifier (e.g. news-2)
-
+
@param pretty_name The english name to use for the site-map and
for things like context bars. Defaults to the name of the object
mounted at this node + the package pretty name (e.g. Intranet News)
@@ -269,14 +162,71 @@
-package_key $package_key]
}
+
+ad_proc -public subsite::get {
+ {-subsite_id {}}
+ {-array:required}
+} {
+ Get information about a subsite.
+
+ @param subsite_id The id of the subsite for which info is requested.
+ If no id is provided, then the id of the closest ancestor subsite will
+ be used.
+ @param array The name of an array in which information will be returned.
+
+ @author Frank Nikolajsen (frank@warpspace.com)
+ @creation-date 2003-03-08
+} {
+ upvar $array subsite_info
+
+ if { [empty_string_p $subsite_id] } {
+ set subsite_id [site_node_closest_ancestor_package "acs-subsite"]
+ }
+
+ array unset subsite_info
+ array set subsite_info [site_node::get_from_object_id -object_id $subsite_id]
+}
+
+ad_proc -public subsite::get_element {
+ {-subsite_id {}}
+ {-element:required}
+ {-notrailing:boolean}
+} {
+ Return a single element from the information about a subsite.
+
+ @param subsite_id The node id of the subsite for which info is requested.
+ If no id is provided, then the id of the closest ancestor subsite will
+ be used.
+ @param element The element you want, one of:
+ directory_p object_type package_key package_id name pattern_p
+ instance_name node_id parent_id url object_id
+ @notrailing If true and the element requested is an url, then strip any
+ trailing slash ('/'). This means the empty string is returned for the root.
+ @return The element you asked for
+
+ @author Frank Nikolajsen (frank@warpspace.com)
+ @creation-date 2003-03-08
+} {
+ get -subsite_id $subsite_id -array subsite_info
+
+ if { $notrailing_p && [string match $element "url"]} {
+ set returnval [string trimright $subsite_info($element) "/"]
+ } else {
+ set returnval $subsite_info($element)
+ }
+
+ return $returnval
+}
+
+
ad_proc subsite::util::sub_type_exists_p {
object_type
} {
returns 1 if object_type has sub types, or 0 otherwise
@author Oumi Mehrotra (oumi@arsdigita.com)
@creation-date 2000-02-07
-
+
@param object_type
} {
@@ -328,7 +278,7 @@
@author Oumi Mehrotra (oumi@arsdigita.com)
@creation-date 2000-02-07
-
+
@param object_type
} {
return [db_string select_pretty_name {
Index: openacs-4/packages/acs-subsite/tcl/subsite-procs.xql
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-subsite/tcl/Attic/subsite-procs.xql,v
diff -u -r1.3 -r1.4
--- openacs-4/packages/acs-subsite/tcl/subsite-procs.xql 10 Oct 2001 06:56:44 -0000 1.3
+++ openacs-4/packages/acs-subsite/tcl/subsite-procs.xql 17 May 2003 09:58:37 -0000 1.4
@@ -1,9 +1,21 @@
To administer the site-wide services of OpenACS, use:
+-
+
- @instance_name@
+
-
+
- Users +
- Package Manager +
- Cache Info +
- Tests +
The Site-Wide Administration service is not available. If you are a + site-wide administrator, use the Site Map to + mount the Site-Wide Administration service. This provides an + interface for administering the site-wide services of OpenACS.
+-The package instances are not mounted anywhere else: +set context [list [list . "Site Map"] $page_title] -
-
-"
+set site_node_url [site_node::get_url -node_id $node_id]
-db_foreach packages_unmounted_select {} {
- doc_body_append "
- $name" +db_multirow -extend { url } unmounted packages_unmounted_select {} { + set url "mount-2?[export_vars { expand:multiple root_id node_id package_id }]" } -doc_body_append "
- "
-
-db_foreach packages_mounted_select {} {
- doc_body_append "
- $name" +db_multirow -extend { url } mounted packages_mounted_select {} { + set url "mount-2?[export_vars { expand:multiple root_id node_id package_id}]" } -doc_body_append "
- "
-
-db_foreach packages_singleton_select {} {
- doc_body_append "
- $name" +db_multirow -extend { url } singleton packages_singleton_select {} { + set url "mount-2?[export_vars { expand:multiple root_id node_id package_id}]" } -doc_body_append " -
[ad_footer] Index: openacs-4/packages/acs-subsite/www/permissions/one.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-subsite/www/permissions/one.adp,v diff -u -r1.3 -r1.4 --- openacs-4/packages/acs-subsite/www/permissions/one.adp 20 Jan 2003 22:35:34 -0000 1.3 +++ openacs-4/packages/acs-subsite/www/permissions/one.adp 17 May 2003 10:02:04 -0000 1.4 @@ -16,12 +16,14 @@
#acs-subsite.Direct_Permissions#
#acs-subsite.none#
@@ -40,15 +42,25 @@#acs-subsite.none#
+ [return to application] +
+In order to make it possible to use ad_form to build common form snippets within procs, code @@ -114,7 +114,7 @@ If the validation check returns true, one of the new_data or edit_data code blocks will be executed depending on whether or not "my_table_key" was defined during the initial request. "my_table_key" is passed as a hidden form variable and is signed and verified, reducing the opportunity for key spoofing by malicious outsiders. - +
This example includes dummy redirects to a script named "somewhere" to make clear the fact that after @@ -171,27 +171,38 @@
+
-
+
@@ -292,7 +307,7 @@ ad_form. If the sequence name is not specified, the sequence acs_object_id_seq is used to generate new keys. Examples: - +
- +my_key:key@@ -301,7 +316,7 @@
- +my_key:key(some_sequence_name)@@ -310,7 +325,7 @@
{my_key:text(multiselect),multiple {label "select some values"}
{options {first second third fourth fifth}}
@@ -322,7 +337,7 @@
- +{hide_me:text(hidden) {value 3}}@@ -331,7 +346,7 @@
start_date:date,to_sql(sql_date),to_html(sql_date),optional@@ -363,7 +378,7 @@ } set valid_args { form method action mode html name select_query select_query_name new_data on_refresh - edit_data validate on_submit after_submit confirm_template new_request edit_request + edit_data validate on_submit after_submit confirm_template on_request new_request edit_request export cancel_url cancel_label has_edit actions }; ad_arg_parser $valid_args $args @@ -672,12 +687,16 @@ after_html - result_datatype - search_query - - search_query_name { + search_query_name - + maxlength { if { [llength $extra_arg] > 2 || [llength $extra_arg] == 1 } { return -code error "element $element_name: \"$extra_arg\" requires exactly one argument" } lappend form_command [uplevel [list subst [lindex $extra_arg 1]]] } + default { + ns_log Error "Unknown switch '[lindex $extra_arg 0]' to ad_form on url [ad_return_url]" + } } } eval $form_command @@ -725,90 +744,108 @@ return } - if { [template::form is_request $form_name] && [info exists af_key_name($form_name)] } { + if { [template::form is_request $form_name] } { - set key_name $af_key_name($form_name) - upvar #$level $key_name $key_name upvar #$level __ad_form_values__ values - # Check to see if we're editing an existing database value - if { [info exists $key_name] } { - if { [info exists edit_request] } { - if { [info exists select_query] || [info exists select_query_name] } { - return -code error "Edit request block conflicts with select query" - } - ad_page_contract_eval uplevel #$level $edit_request - foreach element_name $af_element_names($form_name) { - if { [llength $element_name] == 1 } { - if { [uplevel \#$level [list info exists $element_name]] } { - set values($element_name) [uplevel \#$level [list set $element_name]] + if { [template::form is_request $form_name] && [info exists on_request] } { + ad_page_contract_eval uplevel #$level $on_request + foreach element_name $af_element_names($form_name) { + if { [llength $element_name] == 1 } { + if { [uplevel \#$level [list info exists $element_name]] } { + set values($element_name) [uplevel \#$level [list set $element_name]] + if { [info exists af_from_sql(${form_name}__$element_name)] } { + set values($element_name) [template::util::$af_type(${form_name}__$element_name)::acquire \ + $af_from_sql(${form_name}__$element_name) $values($element_name)] } } - } + } + } + } - } else { + if { [info exists af_key_name($form_name)] } { - # The key exists, grab the existing values if we have an select_query clause + set key_name $af_key_name($form_name) + upvar #$level $key_name $key_name - if { ![info exists select_query] && ![info exists select_query_name] } { - return -code error "Key \"$key_name\" has the value \"[set $key_name]\" but no select_query or select_query_name clause exists" - } + # Check to see if we're editing an existing database value + if { [info exists $key_name] } { + if { [info exists edit_request] } { + if { [info exists select_query] || [info exists select_query_name] } { + return -code error "Edit request block conflicts with select query" + } + ad_page_contract_eval uplevel #$level $edit_request + foreach element_name $af_element_names($form_name) { + if { [llength $element_name] == 1 } { + if { [uplevel \#$level [list info exists $element_name]] } { + set values($element_name) [uplevel \#$level [list set $element_name]] + } + } + } - if { [info exists select_query_name] } { - set select_query "" } else { - set select_query_name "" - } - if { ![uplevel #$level [list db_0or1row $select_query_name [join $select_query " "] -column_array __ad_form_values__]] } { - return -code error "Error when selecting values" - } + # The key exists, grab the existing values if we have an select_query clause - foreach element_name $af_element_names($form_name) { - if { [llength $element_name] == 1 } { - if { [info exists af_from_sql(${form_name}__$element_name)] } { - set values($element_name) [template::util::$af_type(${form_name}__$element_name)::acquire \ - $af_from_sql(${form_name}__$element_name) $values($element_name)] + if { ![info exists select_query] && ![info exists select_query_name] } { + return -code error "Key \"$key_name\" has the value \"[set $key_name]\" but no select_query or select_query_name clause exists" + } + + if { [info exists select_query_name] } { + set select_query "" + } else { + set select_query_name "" + } + + if { ![uplevel #$level [list db_0or1row $select_query_name [join $select_query " "] -column_array __ad_form_values__]] } { + return -code error "Error when selecting values" + } + + foreach element_name $af_element_names($form_name) { + if { [llength $element_name] == 1 } { + if { [info exists af_from_sql(${form_name}__$element_name)] } { + set values($element_name) [template::util::$af_type(${form_name}__$element_name)::acquire \ + $af_from_sql(${form_name}__$element_name) $values($element_name)] + } } } } - } - set values($key_name) [set $key_name] - set values(__new_p) 0 + set values($key_name) [set $key_name] + set values(__new_p) 0 - } else { + } else { - # Make life easy for the OACS 4.5 hacker by automagically generating a value for - # our new database row. Set a local so the query can use bindvar notation (the driver - # doesn't support array bind vars) + # Make life easy for the OACS 4.5 hacker by automagically generating a value for + # our new database row. Set a local so the query can use bindvar notation (the driver + # doesn't support array bind vars) - if { [info exists af_sequence_name($form_name)] } { - set sequence_name $af_sequence_name($form_name) - } else { - set sequence_name "acs_object_id_seq" - } + if { [info exists af_sequence_name($form_name)] } { + set sequence_name $af_sequence_name($form_name) + } else { + set sequence_name "acs_object_id_seq" + } - if { ![db_0or1row get_key "" -column_array values] } { - return -code error "Couldn't get the next value from sequence \"$af_sequence_name($form_name)\"" - } - set values(__new_p) 1 + if { [catch {set values($key_name) [db_nextval $sequence_name]} errmsg]} { + return -code error "Couldn't get the next value from sequence: $errmsg\"" + } + set values(__new_p) 1 - if { [info exists new_request] } { - ad_page_contract_eval uplevel #$level $new_request - # LARS: Set form values based on local vars in the new_request block - foreach element_name $af_element_names($form_name) { - if { [llength $element_name] == 1 } { - if { [uplevel \#$level [list info exists $element_name]] } { - set values($element_name) [uplevel \#$level [list set $element_name]] + if { [info exists new_request] } { + ad_page_contract_eval uplevel #$level $new_request + # LARS: Set form values based on local vars in the new_request block + foreach element_name $af_element_names($form_name) { + if { [llength $element_name] == 1 } { + if { [uplevel \#$level [list info exists $element_name]] } { + set values($element_name) [uplevel \#$level [list set $element_name]] + } } - } - } + } + } } + set values(__key_signature) [ad_sign "$values($key_name):$form_name"] } - set values(__key_signature) [ad_sign "$values($key_name):$form_name"] - foreach element_name $properties(element_names) { if { [info exists values($element_name)] } { if { [info exists af_flag_list(${form_name}__$element_name)] && \ @@ -989,7 +1026,7 @@ This is for pages built with ad_form that handle edit and add requests in one file. It returns 1 if the current form being built for the entry of new data, 0 if for the editing of existing data. - +
It does not make sense to use this in pages that don't use ad_form. @@ -1016,7 +1053,7 @@ } { set form [ns_getform] - + return [expr {[empty_string_p $form] || [ns_set find $form $key] == -1 || [ns_set get $form __new_p] == 1 }] } Fisheye: Tag 1.2 refers to a dead (removed) revision in file `openacs-4/packages/acs-tcl/tcl/form-processing-procs.xql'. Fisheye: No comparison available. Pass `N' to diff? Index: openacs-4/packages/acs-tcl/tcl/navigation-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/navigation-procs.tcl,v diff -u -r1.11 -r1.12 --- openacs-4/packages/acs-tcl/tcl/navigation-procs.tcl 8 Feb 2003 20:31:36 -0000 1.11 +++ openacs-4/packages/acs-tcl/tcl/navigation-procs.tcl 17 May 2003 10:04:18 -0000 1.12 @@ -21,7 +21,7 @@ [list [list url1 text1] [list url2 text2] ... "terminal text"]
and generates the html fragment. In general the higher level - calls like ad_context_bar and ad_admin_context_bar should be + proc ad_context_bar should be used, and then only in the sitewide master rather than on individual pages. @@ -31,7 +31,6 @@ @return html fragment @see ad_context_bar - @see ad_admin_context_bar } { set out {} foreach element [lrange $context 0 [expr [llength $context] - 2]] { @@ -56,7 +55,8 @@ # JCD: Provide something for the name if the instance name is # absent. name is the tail bit of the url which seems like a # reasonable thing to display. - if {[empty_string_p $node(instance_name)]} { + if {[empty_string_p $node(instance_name)] + && [info exists node(name)]} { set node(instance_name) $node(name) } @@ -73,15 +73,14 @@ -separator args } { - Returns a Yahoo-style hierarchical navbar. Includes "Your Workspace" or "Administration" + Returns a Yahoo-style hierarchical navbar. Includes "Administration" if applicable, and the subsite if not global. @param node_id If provided work up from this node, otherwise the current node @param separator The text placed between each link (passed to ad_context_bar_html if provided) @return an html fragment generated by ad_context_bar_html @see ad_context_bar_html - @see ad_admin_context_bar } { if {![parameter::get -package_id [site_node_closest_ancestor_package "acs-subsite"] -parameter ShowContextBarP -default 1]} { return "" @@ -93,11 +92,6 @@ set context [list] - if {[ad_conn user_id] != 0 && ![string match /pvt/home* [ad_conn url]]} { - lappend context [list "[ad_pvt_home]" "[ad_pvt_home_name]"] - } - - set context [concat $context [ad_context_node_list $node_id]] if { [string match admin/* [ad_conn extra_url]] } { @@ -119,74 +113,53 @@ -# a context bar, rooted at the workspace - ad_proc -deprecated -public ad_context_bar_ws args { - Returns a Yahoo-style hierarchical navbar, starting with a link to workspace. + Returns a Yahoo-style hierarchical navbar. Use ad_context_bar instead. @param list of url desc ([list [list url desc] [list url desc] ... "terminal"]) @return an html fragment generated by ad_context_bar_html @see ad_context_bar } { - return [ad_context_bar_html [concat [list [list "[ad_pvt_home]" "[ad_pvt_home_name]"]] $args]] + return [ad_context_bar $args] } # a context bar, rooted at the workspace or index, depending on whether # user is logged in ad_proc -deprecated -public ad_context_bar_ws_or_index args { - Returns a Yahoo-style hierarchical navbar, starting with a link to - either the workspace or /, depending on whether or not the user is - logged in. You should probably be using ad_context_bar and - then only in the sitewide master. + Returns a Yahoo-style hierarchical navbar. Use ad_context_bar instead. @param args list of url desc ([list [list url desc] [list url desc] ... "terminal"]) - @return an html fragment generated by ad_context_bar_html + @return an html fragment generated by ad_context_bar @see ad_context_bar } { - if { [ad_conn user_id] == 0 && ![string match /pvt/home* [ad_conn url]] } { - set choices [list [list "/" [ad_system_name]]] - } else { - set choices [list [list [ad_pvt_home] [ad_pvt_home_name]]] - } - - return [ad_context_bar_html [concat $choices $args]] + return [ad_context_bar $args] } -ad_proc -public ad_admin_context_bar args { - Returns a Yahoo-style hierarchical navbar, starting with links - workspace and admin home. - Suitable for use in pages underneath /admin. +ad_proc -public -deprecated ad_admin_context_bar args { + Returns a Yahoo-style hierarchical navbar. Use ad_context_bar instead. @param args list of url desc ([list [list url desc] [list url desc] ... "terminal"]) - @return an html fragment generated by ad_context_bar_html + @return an html fragment generated by ad_context_bar @see ad_context_bar } { - - if { [llength $args] > 0 } { - set choices [list [list [ad_pvt_home] [ad_pvt_home_name]] \ - [list /acs-admin/ "ACS System Wide Administration"]] - } else { - set choices [list [list [ad_pvt_home] [ad_pvt_home_name]] \ - "ACS System Wide Administration"] - } - - return [ad_context_bar_html [concat $choices $args]] + return [ad_context_bar $args] } ad_proc -public ad_navbar args { produces navigation bar. notice that navigation bar is different - than context bar, which exploits a tree structure. navbar will just - display a list of nicely formatted links. + than context bar, which displays packages in the site map. Navbar will + only generate HTML for those links passed to it. @param args list of url desc ([list [list url desc] [list url desc]]) @return html fragment @see ad_choice_bar + @see ad_context_bar_html } { set counter 0 foreach arg $args { Index: openacs-4/packages/acs-tcl/tcl/openacs-kernel-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/Attic/openacs-kernel-procs.tcl,v diff -u -r1.4 -r1.5 --- openacs-4/packages/acs-tcl/tcl/openacs-kernel-procs.tcl 15 May 2002 04:19:00 -0000 1.4 +++ openacs-4/packages/acs-tcl/tcl/openacs-kernel-procs.tcl 17 May 2003 10:04:18 -0000 1.5 @@ -114,7 +114,6 @@ for {set i 0} {$i < $n_fields} {incr i} { set varname [string tolower [lindex $headers $i]] set varvalue [lindex $one_line $i] - set row_array($varname) $varvalue } Index: openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl,v diff -u -r1.34 -r1.35 --- openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl 12 Feb 2003 18:42:55 -0000 1.34 +++ openacs-4/packages/acs-tcl/tcl/request-processor-procs.tcl 17 May 2003 10:04:18 -0000 1.35 @@ -227,22 +227,21 @@ util_unlist $filter_info filter_index debug_p arg_count proc arg -# if { $debug_p } { -# ns_log "Notice" "Invoking $why filter $proc" -# } rp_debug -debug $debug_p "Invoking $why filter $proc" switch $arg_count { 0 { set errno [catch { set result [$proc] } error] } 1 { set errno [catch { set result [$proc $why] } error] } 2 { set errno [catch { set result [$proc $conn $why] } error] } - default { set errno [catch { - ad_try { - set result [$proc $conn $arg $why] - } ad_script_abort val { - set result "filter_return" - } - } error] } + default { + set errno [catch { + ad_try { + set result [$proc $conn $arg $why] + } ad_script_abort val { + set result "filter_return" + } + } error] + } } global errorCode @@ -258,22 +257,21 @@ [string compare $result "filter_return"] } { set error_msg "error in filter $proc for [ns_conn method] [ns_conn url]?[ns_conn query]. Filter returned invalid result \"$result\"" ad_call_proc_if_exists ds_add rp [list filter [list $why [ns_conn method] [ns_conn url] $proc $arg] $startclicks [clock clicks] "error" $error_msg] - # report the bad filter_return message - rp_debug error $error_msg + # report the bad filter_return message + rp_debug -debug t error $error_msg rp_report_error -message $error_msg - set result "filter_return" + set result "filter_return" } else { ad_call_proc_if_exists ds_add rp [list filter [list $why [ns_conn method] [ns_conn url] $proc $arg] $startclicks [clock clicks] $result] } -# if { $debug_p } { -# ns_log "Notice" "Done invoking $why filter $proc (returning $result)" -# } rp_debug -debug $debug_p "Done invoking $why filter $proc (returning $result)" - if { [string compare $result "filter_return"] } { - rp_finish_serving_page - } +# JCD: Why was this here? the rp_finish_serving_page is called inside the +# handlers and this handles trace filters +# if { [string compare $result "filter_return"] } { +# rp_finish_serving_page +# } return $result } @@ -287,9 +285,6 @@ util_unlist $argv proc_index debug_p arg_count proc arg -# if { $debug_p } { -# ns_log "Notice" "Invoking registered procedure $proc" -# } rp_debug -debug $debug_p "Invoking registered procedure $proc" switch $arg_count { @@ -315,9 +310,6 @@ ad_call_proc_if_exists ds_add rp [list registered_proc [list $proc $arg] $startclicks [clock clicks]] } -# if { $debug_p } { -# ns_log "Notice" "Done invoking registered procedure $proc" -# } rp_debug -debug $debug_p "Done Invoking registered procedure $proc" rp_finish_serving_page @@ -326,8 +318,7 @@ ad_proc -private rp_finish_serving_page {} { global doc_properties if { [info exists doc_properties(body)] } { - set l [string length $doc_properties(body)] - rp_debug "Returning page: $l [ad_quotehtml [string range $doc_properties(body) 0 100]]" + rp_debug "Returning page:[info level [expr [info level] - 1]]: [ad_quotehtml [string range $doc_properties(body) 0 100]]" doc_return 200 text/html $doc_properties(body) } } @@ -468,6 +459,10 @@ ad_conn -set user_id 0 ad_conn -set start_clicks [clock clicks] + ad_call_proc_if_exists ds_collect_connection_info + + + # ------------------------------------------------------------------------- # Start of patch "hostname-based subsites" # ------------------------------------------------------------------------- @@ -634,25 +629,26 @@ ad_proc -private rp_debug { { -debug f } { -ns_log_level notice } string } { - Logs a debugging message, including a high-resolution (millisecond) - timestamp. + Logs a debugging message, including a high-resolution (millisecond) + timestamp. } { - if { [util_memoize {ad_parameter -package_id [ad_acs_kernel_id] DebugP request-processor 0} 60] } { + if { [ad_parameter -package_id [ad_acs_kernel_id] DebugP request-processor 0] } { global ad_conn set clicks [clock clicks] ad_call_proc_if_exists ds_add rp [list debug $string $clicks $clicks] } - if { - [util_memoize {ad_parameter -package_id [ad_acs_kernel_id] LogDebugP request-processor 0} 60] || [string equal $debug t] || [string equal $debug 1] - } { + if { [ad_parameter -package_id [ad_acs_kernel_id] LogDebugP request-processor 0] + || [string equal $debug t] + || [string equal $debug 1] + } { global ad_conn if { [info exists ad_conn(start_clicks)] } { - set timing " ([expr {([clock clicks] - $ad_conn(start_clicks))/1000.0}] ms)" + set timing " ([expr {([clock clicks] - $ad_conn(start_clicks))/1000.0}] ms)" } else { - set timing "" + set timing "" } - ns_log $ns_log_level "RP$timing: $string" + ns_log $ns_log_level "RP$timing: $string" } } @@ -671,9 +667,7 @@ set error_url [ad_conn url] - if { [llength [info procs ds_collection_enabled_p]] == 1 && [ds_collection_enabled_p] } { - ad_call_proc_if_exists ds_add conn error $message - } + ad_call_proc_if_exists ds_add conn error $message if {![ad_parameter -package_id [ad_acs_kernel_id] "RestrictErrorsToAdminsP" dummy 0] || \ [permission::permission_p -object_id [ad_conn package_id] -privilege admin] } { @@ -739,8 +733,6 @@ the server. } { - ad_call_proc_if_exists ds_collect_connection_info - # JCD: keep track of rp_handler call count to prevent dev support from recording # information twice when for example we get a 404 internal redirect. We should probably set recursion_count [ad_conn recursion_count] @@ -1129,6 +1121,9 @@ if { $var == "form" } { return [ns_getform] } + if { $var == "all" } { + return [array get ad_conn] + } if { [info exists ad_conn($var)] } { return $ad_conn($var) @@ -1339,4 +1334,3 @@ ad_proc -private rp_lookup_node_from_host { host } { return [db_string node_id { *SQL* } -default ""] } - Index: openacs-4/packages/acs-tcl/tcl/security-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/security-procs.tcl,v diff -u -r1.13 -r1.14 --- openacs-4/packages/acs-tcl/tcl/security-procs.tcl 15 Sep 2002 22:10:50 -0000 1.13 +++ openacs-4/packages/acs-tcl/tcl/security-procs.tcl 17 May 2003 10:04:18 -0000 1.14 @@ -52,14 +52,10 @@ return [ad_parameter -package_id [ad_acs_kernel_id] SessionLifetime security 604800] } -proc sec_sweep_sessions {} { - set current_time [ns_time] - set property_life [sec_session_lifetime] +ad_proc -private sec_sweep_sessions {} { + set expires [expr {[ns_time] - [sec_session_lifetime]}] - db_dml sessions_sweep { - delete from sec_session_properties - where :current_time - last_hit > :property_life - } + db_dml sessions_sweep {} } proc_doc sec_handler {} { @@ -962,7 +958,9 @@ set url [ad_conn url] if { [string match "*register/*" $url] || [string match "/index*" $url] || \ - [string match "/" $url] } { + [string match "/index*" $url] || \ + [string match "/" $url] || \ + [string match "*password-update*" $url] } { return 1 } @@ -990,17 +988,21 @@ @param secret allows the caller to specify a known secret external to the random secret management mechanism. - @param token_id allows the caller to specify a token_id. + @param token_id allows the caller to specify a token_id which is then ignored so don't use it. @param value the value to be signed. } { - # pick a random token_id + if { [empty_string_p $secret] } { - set token_id [sec_get_random_cached_token_id] + if {[empty_string_p $token_id]} { + # pick a random token_id + set token_id [sec_get_random_cached_token_id] + } set secret_token [sec_get_token $token_id] } else { set secret_token $secret } + ns_log Debug "Security: Getting token_id $token_id, value $secret_token" Index: openacs-4/packages/acs-tcl/tcl/security-procs.xql =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/security-procs.xql,v diff -u -r1.6 -r1.7 --- openacs-4/packages/acs-tcl/tcl/security-procs.xql 13 Mar 2002 22:50:53 -0000 1.6 +++ openacs-4/packages/acs-tcl/tcl/security-procs.xql 17 May 2003 10:04:18 -0000 1.7 @@ -5,7 +5,7 @@delete from sec_session_properties - where :current_time - last_hit > :property_life + where last_hit < :expires
+ A trailing '/' will be appended to $url if required and not present.
+ + If the '-exact' switch is not present and $url is not found, returns the + first match found by successively removing the trailing $url path component.
+ @see site_node::get } { # attempt an exact match @@ -236,20 +225,22 @@ } # chomp off part of the url and re-attempt - while {![empty_string_p $url]} { - set url [string trimright $url /] - set url [string range $url 0 [string last / $url]] + if {!$exact_p} { + while {![empty_string_p $url]} { + set url [string trimright $url /] + set url [string range $url 0 [string last / $url]] - if {[nsv_exists site_nodes $url]} { - array set node [nsv_get site_nodes $url] + if {[nsv_exists site_nodes $url]} { + array set node [nsv_get site_nodes $url] - if {[string equal $node(pattern_p) t] && ![empty_string_p $node(object_id)]} { - return [array get node] - } - } - } + if {[string equal $node(pattern_p) t] && ![empty_string_p $node(object_id)]} { + return [array get node] + } + } + } + } - error "site node not found at url $url" + error "site node not found at url \"$url\"" } ad_proc -public get_from_object_id { @@ -265,10 +256,12 @@ ad_proc -public get_all_from_object_id { {-object_id:required} } { - return a list of site nodes associated with the given object_id + Return a list of site node info associated with the given object_id. + The nodes will be ordered descendingly by url (children before their parents). } { set node_id_list [list] + set url_list [list] foreach url [get_url_from_object_id -object_id $object_id] { lappend node_id_list [get -url $url] } @@ -293,7 +286,10 @@ {-object_id:required} } { returns a list of urls for site_nodes that have the given object - mounted or the empty list if there are none + mounted or the empty list if there are none. The + url:s will be returned in descending order meaning any children will + come before their parents. This ordering is useful when deleting site nodes + as we must delete child site nodes before their parents. } { return [db_list select_url_from_object_id {}] } @@ -342,7 +338,58 @@ return $node(object_id) } - + ad_proc -public closest_ancestor_package { + {-url ""} + {-node_id ""} + {-package_key ""} + } { + Starting with the node at with given id, or at given url, + climb up the site map and return the id of the first not-null + mounted object. If no ancestor object is found the empty string is returned. + The id of the object at the given node itself will never be returned. + + @param url The url of the node to start from. You must provide either url or node_id. + An empty url is taken to mean the main site. + @param node_id The id of the node to start from. Takes precedence over any provided url. + @param package_key Restrict search to objects of this package type. + + @return The id of the first object found and an empty string if no object + is found. Throws an error if no node with given url can be found. + + @author Peter Marklund + } { + # Make sure we have the id of the start node to work with + if { [empty_string_p $node_id] } { + if { [empty_string_p $url] } { + set url "/" + } + + set node_id [site_node::get_node_id -url $url] + } + + # Climb up the site map starting with node_id and stop when we have + # an object to use as context or when we have reached the root node + set loop_node_id $node_id + set main_node_id [site_node::get_node_id -url "/"] + set context_id "" + set context_package_key "___${package_key}" + while { [empty_string_p $context_id] && \ + [expr [empty_string_p $package_key] || [string equal $package_key $context_package_key]]} { + + set loop_node_id [site_node::get_parent_id -node_id $loop_node_id] + + if { [string equal $loop_node_id ""] } { + # There is no parent node - we reached the root of the site map + break + } + + array set node_array [site_node::get -node_id $loop_node_id] + set context_id $node_array(object_id) + set context_package_key $node_array(package_key) + } + + return $context_id + } } ############## @@ -438,10 +485,11 @@ @return The package id of the newly mounted package } { - return [site_node::instantiate_and_mount -parent_node_id $parent_node_id \ - -node_name $url_path_component - -package_name $instance_name \ - -package_key $package_key] + return [site_node::instantiate_and_mount \ + -parent_node_id $parent_node_id \ + -node_name $url_path_component \ + -package_name $instance_name \ + -package_key $package_key] } ad_proc -public site_map_unmount_application { Index: openacs-4/packages/acs-tcl/tcl/text-html-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/text-html-procs.tcl,v diff -u -r1.15 -r1.16 --- openacs-4/packages/acs-tcl/tcl/text-html-procs.tcl 19 Feb 2003 15:09:28 -0000 1.15 +++ openacs-4/packages/acs-tcl/tcl/text-html-procs.tcl 17 May 2003 10:04:18 -0000 1.16 @@ -18,6 +18,7 @@ -no_links:boolean -no_lines:boolean -no_quote:boolean + -includes_html:boolean text } { Converts plaintext to html. Also translates any recognized @@ -71,7 +72,7 @@ # Convert line breaks if { !$no_lines_p } { - set text [util_convert_line_breaks_to_html $text] + set text [util_convert_line_breaks_to_html -includes_html=$includes_html_p -- $text] } if { !$no_quote_p } { @@ -103,6 +104,7 @@ } ad_proc -public util_convert_line_breaks_to_html { + {-includes_html:boolean} text } { Convert line breaks to
and
tags, respectively.
@@ -115,8 +117,8 @@
regsub -all {\r\n} $text "\n" text
regsub -all {\r} $text "\n" text
- # Remove whitespace around \n's
- regsub -all {\s+\n\s+} $text "\n" text
+ # Remove whitespace before \n's
+ regsub -all {[ \t]*\n} $text "\n" text
# Wrap P's around paragraphs
set text "
$text
" @@ -125,6 +127,15 @@ # Convert _single_ CRLF's to's to preserve line breaks # Lars: This must be done after we've made P tags, because otherwise the line # breaks will already have been converted into BR's. + + # remove line breaks right before and after HTML tags that will insert a paragraph break themselves + if { $includes_html_p } { + 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 + } + } + regsub -all {\n} $text "
\n" text # Add line breaks to P tags @@ -685,6 +696,7 @@ 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. @@ -694,7 +706,8 @@ @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 Lars Pind (lars@pinds.com) @author Aaron Swartz (aaron@swartzfam.com) @creation-date 19 July 2000 @@ -815,8 +828,8 @@ ad_html_to_text_put_text output "_" } a { - if { [empty_string_p $slash] } { - if { [info exists attribute_array(href)] } { + if { [empty_string_p $slash] && !$no_format_p} { + if { [info exists attribute_array(href)] } { if { [info exists attribute_array(title)] } { set title ": '$attribute_array(title)'" } else { @@ -1282,7 +1295,7 @@ @author Lars Pind (lars@pinds.com) @creation-date 2003-01-27 } { - return [ad_text_to_html -no_quote -- [util_close_html_tags $text]] + return [ad_text_to_html -no_quote -includes_html -- [util_close_html_tags $text]] } ad_proc -public ad_enhanced_text_to_plain_text { @@ -1377,6 +1390,7 @@ ad_proc string_truncate { {-len 200} {-format html} + {-no_format:boolean} string } { Truncates a string to len characters (defaults to the @@ -1387,6 +1401,7 @@ @param len The lenght to truncate to. Defaults to parameter TruncateDescriptionLength. @param format html or text. + @param no_format causes hyperlink tags not to get listed at the end of the output. @param string The string to truncate. @return The truncated string, with HTML tags cloosed or converted to text, depending on format. @@ -1398,10 +1413,14 @@ set string "[string range $string 0 $len]..." } - if { [string equal $format "html"] } { + if { [string equal $format "html"] && !$no_format_p } { set string [util_close_html_tags $string] } else { - set string [ad_html_to_text -- $string] + if { $no_format_p } { + set string [ad_html_to_text -no_format $string] + } else { + set string [ad_html_to_text -- $string] + } } return $string } Index: openacs-4/packages/acs-tcl/tcl/user-extensions-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/user-extensions-procs.tcl,v diff -u -r1.3 -r1.4 --- openacs-4/packages/acs-tcl/tcl/user-extensions-procs.tcl 16 Jan 2003 13:41:57 -0000 1.3 +++ openacs-4/packages/acs-tcl/tcl/user-extensions-procs.tcl 17 May 2003 10:04:18 -0000 1.4 @@ -20,7 +20,8 @@ } { Dispatches (calls the service contract routines) the requested - method so that the operation gets executed. + method so that the operation gets executed, and packages are + notified of changes in user information. } { if {[empty_string_p $impl]} { @@ -44,39 +45,49 @@ ad_proc -public user_new { {-user_id:required} } { - New User + Notifies packages when a new user is added to the system. + + @see dispatch } { dispatch -op UserNew -list_of_args [list $user_id] } ad_proc -public user_approve { {-user_id:required} } { - Approve User + Notifies packages when a user is approved. + + @see dispatch } { dispatch -op UserApprove -list_of_args [list $user_id] } ad_proc -public user_deapprove { {-user_id:required} } { - Deapprove User + Notifies packages when a user is deapproved. + + @see dispatch } { dispatch -op UserDeapprove -list_of_args [list $user_id] } ad_proc -public user_modify { {-user_id:required} } { - Modify User + Notifies packages when a user is modified. + + @see dispatch } { dispatch -op UserModify -list_of_args [list $user_id] } ad_proc -public user_delete { {-user_id:required} } { - Delete User + Notifies packages when a user is deleted. + + @see dispatch } { dispatch -op UserDelete -list_of_args [list $user_id] } Index: openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl,v diff -u -r1.31 -r1.32 --- openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 28 Apr 2003 08:52:10 -0000 1.31 +++ openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 17 May 2003 10:04:18 -0000 1.32 @@ -2726,6 +2726,30 @@ return $set_id } +ad_proc -public util_sets_equal_p { list1 list2 } { + Tests whether each unique string in list1 occurs as many + times in list1 as in list2 and vice versa (regarless of order). + + @return 1 if the lists have identical sets and 0 otherwise + + @author Peter Marklund +} { + if { [llength $list1] != [llength $list2] } { + return 0 + } + + set sorted_list1 [lsort $list1] + set sorted_list2 [lsort $list2] + + for { set index1 0 } { $index1 < [llength $sorted_list1] } { incr index1 } { + if { ![string equal [lindex $sorted_list1 $index1] [lindex $sorted_list2 $index1]] } { + return 0 + } + } + + return 1 +} + ad_proc -public ad_tcl_list_list_to_ns_set { -set_id -put:boolean Index: openacs-4/packages/acs-tcl/tcl/widgets-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/widgets-procs.tcl,v diff -u -r1.4 -r1.5 --- openacs-4/packages/acs-tcl/tcl/widgets-procs.tcl 2 Sep 2002 15:18:30 -0000 1.4 +++ openacs-4/packages/acs-tcl/tcl/widgets-procs.tcl 17 May 2003 10:04:18 -0000 1.5 @@ -208,7 +208,7 @@ set value [lindex $opt 0] if { (!$multiple && [string compare $value $default] == 0) || ($multiple && [lsearch -exact $default $value] > -1)} { - append retval "\n" + append retval "\n" } else { append retval "\n" } Index: openacs-4/packages/acs-templating/acs-templating.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-templating/acs-templating.info,v diff -u -r1.12 -r1.13 --- openacs-4/packages/acs-templating/acs-templating.info 19 Feb 2003 15:17:57 -0000 1.12 +++ openacs-4/packages/acs-templating/acs-templating.info 17 May 2003 10:04:33 -0000 1.13 @@ -7,340 +7,28 @@
+
+
| |||||||||||||||||||||||||||||||||||
![](\"/shared/images/${type}\$checked\")
"
+ # This is ugly, but it works: Only export the value when we're on a selected option
+ append output "\[ad_decode \$checked \"checked\" \"\" \"\"\]"
+ }
+ default {
+ if { [info exists element(value)] } {
+ append output [ad_quotehtml $element(value)]
+ append output ""
+ }
+ }
+ }
+ } else {
+ set output ""
@@ -269,7 +284,7 @@
# Create an array for easier testing of selected values
template::util::list_to_lookup $values_list values
-
+
if { ![string equal $mode "edit"] } {
set selected_list [list]
set output {}
@@ -300,16 +315,20 @@
append output ">\n"
foreach option $options_list {
-
+
set label [lindex $option 0]
set value [lindex $option 1]
-
- append output " \n"
}
@@ -386,13 +405,8 @@
}
set query $element(search_query)
- if { [info exists element(search_query_name)] } {
- set query_name $element(search_query_name)
- } else {
- set query_name "get_options"
- }
- set options [db_list_of_lists $query_name $query]
+ set options [db_list_of_lists get_options $query]
set option_count [llength $options]
Index: openacs-4/packages/acs-templating/www/doc/api/element.html
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-templating/www/doc/api/element.html,v
diff -u -r1.1 -r1.2
--- openacs-4/packages/acs-templating/www/doc/api/element.html 13 Mar 2001 22:59:27 -0000 1.1
+++ openacs-4/packages/acs-templating/www/doc/api/element.html 17 May 2003 10:05:51 -0000 1.2
@@ -23,6 +23,7 @@
name { expression } { message } \
... } \
-options { { label value } { label value } ... } \
+ -maxlength maxlength \
-value value \
-values { value value ... }