" + } + foreach invalid_question $invalid_questions { + set invalid_id [fst $invalid_question] + set invalid_msg [snd $invalid_question] + set pretty_name [lindex $pretty_names [lsearch $question_ids $invalid_id]] + append message "You have entered an invalid entry for $pretty_name ($invalid_msg)
" + } + set i [expr [llength $invalid_questions] + [llength $missing_ids]] + if { $i } { + return [list $i $message] + } else { + return + } +} + +proc_doc km_upload_exists_p { object_id question_id } { + Looks if a file has been uploaded for this object_id and question_id +} { + set client_filename [db_string km_upload_exists_p " + select content from sn_content + where object_id=:object_id + and question_id=:question_id" -default ""] + + if ![empty_string_p $client_filename] { + return 1 + } else { + return 0 + } +} + +ad_proc km_original_author_p { user_id object_id } { + Test if the user is the original author of this object. +} { + set context_id [ad_conn package_id] + set result [db_string km_original_author_p " + select count(*) from sn_objects where object_id=:object_id and original_author_id=:user_id and context_id=:context_id"] + + return $result +} + +proc_doc km_type_has_data_type_p { object_type_id data_type } { + Determines if an object type has a column of the given abstract datatype. +} { + return [db_string km_type_has_data_type_p " + select decode(count(*),0,0,1) from dual where exists (select 1 + from sn_questions q, sn_question_object_type_map qm + where qm.question_id = q.question_id + and qm.object_type_id = :object_type_id + and qm.question_state <> 'invisible' + and q.abstract_data_type = :data_type)"] +} + +# ******************** Date Procs ******************** + +proc_doc month_list {} { + Returns a list of months, the second row holds the corresponding 2 digit values. +} { + set months [list Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec] + set values [list 01 02 03 04 05 06 07 08 09 10 11 12] + return [list $months $values] +} + +proc_doc km_default_date {question_id} { + Calculates a default date based on the question_id +} { + set default_value [db_string km_default_date_1 " + select default_value from sn_questions where question_id=:question_id" -default ""] + if [empty_string_p $default_value] { + set result {} + } else { + if { ![catch {set default_date [db_string km_default_date_2 "select $default_value from dual"]}] } { + set result [km_break_date $default_date] + } else { + set result {} + } + } + return $result +} + +ad_proc km_get_year_range {question_id} { + Calculates the year range for this date question +} { + db_1row get_year_range { + select (to_char(add_months(sysdate,12*year_from),'YYYY')) as year_from, + (to_char(add_months(sysdate,12*year_to),'YYYY')) as year_to + from sn_questions + where question_id = :question_id + } + return [list $year_from $year_to] +} + +ad_proc km_assemble_dates { {-filter_p 1} keys values } { + + Given a list of keys and values, this proc searches for all keys with the form + key_name:month, key_name:year, key_name:day, which is how km-date-tags + returns them in this module. It returns a list of key value tuples + of the form: key_name YYYY-MM-DD. It does not check if these are valid dates, that's + what date_p does. If filter_p is set to 1, it returns only the date tuples back. + Otherwise it returns all other keys and values in the same order. + +} { + # we need a list of key_name tags and their values, sort them so that + # all key_names are grouped together and that :day, :month, :year + # will be evaluated in that order + + set key_name "" + set tuples [zip $keys $values] + set tuples [qsort $tuples] + set last_key_name "" + set result [list] + + set counter 0 + foreach tuple $tuples { + + if { [regexp {(.*)\.(month|year|day)} [fst $tuple] match key_name] } { + # Looks like a date value. + + if { [string compare $key_name $last_key_name] == 0 } { + lappend ${key_name}_value [snd $tuple] + } else { + + # It's a different key_name so append the last_key_name and + # its date to the list (if there is one). + + if ![empty_string_p $last_key_name] { + lappend dates [list $last_key_name [set ${last_key_name}_value]] + } + + # Start assembling the next date + lappend ${key_name}_value [snd $tuple] + } + + set last_key_name $key_name + incr counter + + } elseif !$filter_p { + # No date value, but we are not allowed to filter other values out. + # So just copy it. + + lappend result $tuple + } + } + + if { $counter } { + + # Append the last last_key_name and its date to the list. + lappend dates [list $last_key_name [set ${last_key_name}_value]] + + # Oracle will want the date YYY-MM-DD instead of a list DD MM YYYY, + # so split the tuples up again and format the date part. + + set formatted_dates [map {flip join "-"} [map reverse [snd [transpose $dates]]]] + + # Pack them up again to be returned as a list of tuples. + set result "$result [zip [fst [transpose $dates]] $formatted_dates]" + } + + return $result +} + + +# ******************** Navigation ******************** + +proc_doc generate_path_id {} { + + Generates a random number to uniquely define this excursion state in + the knowledge management library. + + This number will be passed from one form to the next throughout the excursion. + +} { + while 1 { + # Note that ns_rand only gives us six digits - so we call it twice. + set path_id "[ns_rand 1000000][ns_rand 1000000]" + + if ![db_string generate_path_id "select count(*) from km_path where path_id=:path_id"] { + return $path_id + } + } +} + +ad_proc set_path_values {{-question_id ""} object_id category_id } { + + Returns a simple list of name and value tuples that should be stored + for library excursions in the km_excursion_path table + +} { + + if ![empty_string_p $question_id] { + set values [list object_id $object_id question_id $question_id category_id $category_id] + } else { + set values [list object_id $object_id category_id $category_id] + } + return $values +} + +ad_proc init_path { + { + -last_path_id "" + } + values_list return_to action +} { + + Initializes the path variable for an excursion through the library. + + Begins an excursion by saving all the information that will be + necessary at the end of this excursion to return to the same place it + started. It is assumed that an excursion is only occuring while + editing, creating or linking an object. In all other cases there will + be no excursion state and also no object_id. Important! The + last_path_id that is being passed is the id of the excursion state out + of which this excursion is being launched! + +} { + set path_id [generate_path_id] + if [empty_string_p $last_path_id] { set last_path_id [db_null] } + + # Insert the info about this particular excursion into the database + + db_dml init_path "insert into km_path + (path_id, last_path_id, action, values_list, return_to, start_time) + values (:path_id, :last_path_id, :action, + :values_list, :return_to, sysdate)" + + return $path_id +} + +proc_doc get_path_return_url {path_id} { + + Returns the destination of a path if it's a valid path, otherwise + it returns an empty string. + +} { + if [empty_string_p $path_id] { return "" } + + set calc_excursion_timeout [expr [excursion_timeout]/24] + set sql "select return_to from km_path + where path_id=:path_id and sysdate - start_time < :calc_excursion_timeout" + + if {[catch {set destination [db_string get_path_return_url $sql]}]} { + set result "" + } else { + set result $destination + } + + return $result +} + +ad_proc get_path_values { {-action_only_p 1} path_id } { + + Given an excursion's path_id, this proc returns the action of this + excursion as a two-part list: {action action_value}. This is often + necessary for a page to know what it is supposed to do. If the option + action_only_p is set to 0 then a simple list is returned with the name + and value of the variables in the same order that they were given to + km_set_path_values + +} { + + set timeout [excursion_timeout] + + if !$action_only_p { + # Return a list with all excursion details + set values ", values_list " + } else { + set values "" + } + + # Get out the action and the list of values from oracle and + # turn it into a list of action and the other values + + set values_list {} + if { ![db_0or1row get_path_values " + select action $values from km_path + where path_id=:path_id and sysdate - start_time < :timeout/24"]} { + set result {} + } else { + + split $values_list + + set result {} + foreach value $values_list { lappend result $value } + lappend result action $action + } + + return $result +} + +proc_doc get_path_action {path_id} { + Returns the path's action as a plain value. +} { + return [snd [get_path_values $path_id]] +} + +proc_doc get_last_path {path_id} { + + If this was an excursion launched within another excursion then we + want to return the path_id of that excursion. + +} { + set last_path_id [db_string get_last_path " + select last_path_id from km_path where path_id=:path_id" -default ""] + + return $last_path_id +} + +proc_doc path_valid_p {path_id} { + Checks if the given path (still) exists. +} { + if [empty_string_p $path_id] { return 0 } + + set calc_excursion_timeout [expr [excursion_timeout]/24] + set result [db_string path_valid_p " + select count(*) from km_path + where path_id=:path_id and sysdate - start_time <= :calc_excursion_timeout"] + return $result +} + +proc_doc value_from_tuples {key_values key} { + + Given a list of key/value tuples, returns the value associated with + the given key. + +} { + if { [lsearch $key_values $key] == -1 } { + return "" + } else { + return [lindex $key_values [expr [lsearch $key_values $key] + 1]] + } +} + +ad_proc sn_success_story_id {} { + Returns the object_type_id for the Success Stories. +} { + set context_id [ad_conn package_id] + set result [db_string sn_success_story_id " + select object_type_id from sn_object_types + where upper(pretty_name) = upper('success story') and context_id=:context_id" -default "0"] + + return $result +} + + +ad_proc km_workflow_task_per_object {object_id} { + Return information about the current workflow task for this object_id +} { + # dirk: remove the rownum - it's only in for debugging purposes. + if {[db_0or1row km_workflow_task_per_object { + select t.task_id, + t.case_id, + t.transition_key, + t.state, + t.transition_name as task_name + from wf_cases c, + wf_user_tasks t + where c.case_id = t.case_id + and c.object_id=:object_id + and rownum=1}]} { + return [list \ + workflow_task_p t \ + task_id $task_id \ + case_id $case_id \ + transition_key $transition_key \ + state $state \ + task_name $task_name] + } else { + return [list \ + workflow_task_p f \ + task_id "" \ + case_id "" \ + transition_key "" \ + state "" \ + task_name ""] + } + return "" +} + + +ad_proc library_approval_process_notifications {} { + + Processes the notifications queued in table wf_library_notifications. + +} { + # Make sure that only one thread is processing the queue at a time. + if {[nsv_incr library library_notifications_p] > 1} { + nsv_incr library library_notifications_p -1 + return + } + + with_finally { + + db_foreach get_notifications { + select notification_id, task_id, template_key, recipient_id, sender_id, body + from wf_library_notifications + } { + + db_1row ticket_info { + select o.object_id, + o.one_line_description as shortname, sn.node_id, + u1.email as sender_email, u2.email as recipient_email, + u1.first_names || ' ' || u1.last_name as sender_name, + u2.first_names || ' ' || u2.last_name as recipient_name, + apm_package.name(o.context_id) as package_name + from wf_tasks wt, wf_cases wc, sn_objects o, users u2, + site_nodes sn, users u1 + where u1.user_id = :sender_id + and u2.user_id = :recipient_id + and wc.case_id = wt.case_id + and wt.task_id = :task_id + and o.object_id = wc.object_id + and sn.object_id = o.context_id + } + + set community_id [sn_community::leaf_community $node_id] + + set replacement_list \ + [list \ + object_id $object_id \ + object_link "[ad_url]/o/$object_id" \ + package_name $package_name \ + shortname $shortname \ + submitter_name $sender_name \ + submitter_email $sender_email \ + recipient_email $recipient_email \ + notification_sender $sender_email \ + body $body] + + db_dml delete_notification { + delete from wf_library_notifications + where notification_id = :notification_id + } + + et_send_email [et_process -community_id $community_id $template_key $replacement_list] + } + + } finally { + nsv_incr library library_notifications_p -1 + } +} + + +util_report_successful_library_load Index: openacs-4/contrib/obsolete-packages/library/tcl/km-access-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/tcl/km-access-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/tcl/km-access-procs.tcl 2 Jul 2003 12:19:41 -0000 1.1 @@ -0,0 +1,315 @@ +# /tcl/km-access-procs.tcl +# +# Functions related to access control. +# +# Created by carsten@arsdigita.com in June 2000 +# +# $Id: km-access-procs.tcl,v 1.1 2003/07/02 12:19:41 peterm Exp $ + +ad_proc km_check_object_id { + { + -check_deleted_p 1 + -check_read_p 1 + -check_edit_p 0 + -check_delete_p 0 + -print_errors_p 1 + } + object_id +} { + + Check if the object exists, and print an error message if it + doesn't. Returns 0 if the object_id is invalid. + + If check_deleted_p is 1, also checks if the object has been deleted. + If check_read_p is 1, also checks if the user may view the object. + If check_edit_p is 1, also checks if the user may edit the object. + Only complains to the user if print_errors_p is 1. + +} { + set package_id [ad_conn package_id] + set user_id [ad_conn user_id] + + if { ![db_0or1row get_object_info " + select decode(sign(sysdate-o.expiration_date),1,1,0,1,0) as deleted_p, + o.original_author_id, o.expiration_date, o.object_type_id, + o.one_line_description as object_name, o.overview, + o.last_modifying_user_id, o.start_date, o.end_date, + decode(o.public_p,'t',1,0) as public_p, o.public_until, + decode(o.archived_p,'t',1,0) as archived_p, + o.original_author_id, to_char(o.creation_date) as creation_date, + to_char(o.last_modified) as last_modified, + to_char(o.user_checkoff_date) as user_checkoff_date, + u.first_names || ' ' || u.last_name as original_author_name, + u.email as original_author_email, o.publisher_id, + decode([tcl_permission_p ":object_id" ":user_id" "'read'"],'t',1,0) as read_p, + decode([tcl_permission_p ":object_id" ":user_id" "'write'"],'t',1,0) as write_p, + decode([tcl_permission_p ":object_id" ":user_id" "'delete'"],'t',1,0) as delete_p, + decode([tcl_permission_p ":package_id" ":user_id" "'admin'"],'t',1,0) as admin_p, + decode([tcl_permission_p ":package_id" ":user_id" "'km_publish'"],'t',1,0) as publish_p, + decode(acs_permission.permission_p(o.object_type_id, :user_id, 'create'),'t',1,0) as create_p, + nvl(o.access_total,0) as access_total, nvl(o.access_month,0) as access_month, + decode(o.in_review_p,'t',1,0) as in_review_p + from sn_objects o, users u + where o.object_id = :object_id + and u.user_id = o.original_author_id + "] } { + # Error: The object does not exist. + + if { $print_errors_p } { + ad_return_exception_page 404 "Entry does not exist." " + The entry with id $object_id does not exist. + We never really delete object IDs from the database so this is quite + unusual. Unless you tried to hack the URL manually this might be a bug + in our software." + } + return 0 + } + + if { [empty_string_p $object_name] } { + set object_name "Unnamed [km_static object_type_pretty_name $object_type_id]" + } + # review process enabled? + if { [km_static approval_p $package_id] && !$publish_p } { + if {$public_p || $in_review_p} { + # revoke delete permission from object owners if object is + # public or review process started + set delete_p $admin_p + } + } + + # The state of a workflow task is user-dependant! + if {$in_review_p} { + set state [db_string workflow_case_state {select distinct t.transition_key + from wf_cases c, + wf_user_tasks t + where c.case_id = t.case_id + and c.object_id=:object_id + and c.state = 'active' + and rownum = 1 + order by t.transition_key desc} -default ""] + } else { + set state "" + } +## and t.user_id = :user_id + + km_conn -reset + km_conn -set public_p $public_p + km_conn -set archived_p $archived_p + km_conn -set deleted_p $deleted_p + km_conn -set expiration_date $expiration_date + km_conn -set object_type_id $object_type_id + km_conn -set object_name $object_name + km_conn -set overview $overview + km_conn -set original_author_id $original_author_id + km_conn -set original_author_name $original_author_name + km_conn -set original_author_email $original_author_email + km_conn -set creation_date $creation_date + km_conn -set last_modified $last_modified + km_conn -set user_checkoff_date $user_checkoff_date + km_conn -set admin_p $admin_p + km_conn -set publish_p $publish_p + km_conn -set read_p $read_p + km_conn -set write_p $write_p + km_conn -set delete_p $delete_p + km_conn -set create_p $create_p + km_conn -set last_modifying_user_id $last_modifying_user_id + km_conn -set access_total $access_total + km_conn -set access_month $access_month + km_conn -set public_until $public_until + km_conn -set start_date $start_date + km_conn -set end_date $end_date + km_conn -set publisher_id $publisher_id + km_conn -set in_review_p $in_review_p + km_conn -set review_state $state + + if { $check_deleted_p && $deleted_p } { + # Error: The object has been deleted. + + set expiration_date [util_AnsiDatetoPrettyDate $expiration_date] + + if {![empty_string_p $last_modifying_user_id]} { + # If we know who deleted the object, we want to give the + # user a link to that user's community page. + + set deletor_name [db_string km_check_object_id_2 " + select first_names || ' ' || last_name + from users where user_id=:last_modifying_user_id"] + + set deletion_text "This object was deleted on $expiration_date by [ad_present_user $last_modifying_user_id $deletor_name]." + + set reason_for_deleting [db_string km_check_object_id_3 " + select reason_for_deleting + from sn_object_delete_reasons + where object_id=:object_id" -default ""] + + if {![empty_string_p $reason_for_deleting]} { + append deletion_text "
Reason:
$reason_for_deleting" + } + + } else { + set deletion_text "This object was deleted on $expiration_date." + } + + if { $print_errors_p } { ad_returnredirect "object-deleted?object_id=$object_id" } + + return 0 + } + + if { $check_read_p && !$read_p } { + # A user only has read access if the object is public, + # or he has been given read permission. + + if { $print_errors_p } { + ad_return_forbidden "Not Authorized" \ + "You are not authorized to view this object." + } + return 0 + } elseif { $check_edit_p && !$admin_p && (!$write_p || $archived_p) } { + if { $print_errors_p } { + ad_return_forbidden "Not Authorized" \ + "You are not authorized to edit this object." + } + return 0 + } elseif { $check_delete_p && !$admin_p && !$delete_p } { + if { $print_errors_p } { + ad_return_forbidden "Not Authorized" \ + "You are not authorized to delete this object." + } + return 0 + } + + # Check if the object type (still) exists, and if the user is allowed + # to view it. + + if { [km_static object_type_deleted_p $object_type_id] } { + if { $print_errors_p } { + # Only complain to the user if we were told so. + + set pretty_type [km_static object_type_pretty_name $object_type_id] + ad_return_exception_page 404 "The object type \"$pretty_type\" has been removed from the system." "The object type \"$pretty_type\" has been removed from the system. +You therefore cannot view this object" + } + return 0 + } + + if { $check_read_p && ![km_static object_type_public_p $object_type_id] && !$admin_p } { + # The object type may not be viewed by this user. + + if { $print_errors_p } { + ad_return_forbidden "Not Authorized" \ + "You are not authorized to view this object." + } + return 0 + } + + return 1 +} + +ad_proc km_check_object_type_id { + { + -check_view_p 1 + -check_create_p 0 + -print_errors_p 1 + } + object_type_id +} { + + Check if the user may access the given object type. Checks for + read and create permissions, whether the object type + has been deleted, and whether it belongs to the current package. + + If check_create_p is set, also complains when the object type + is not browsable. + +} { + set package_id [ad_conn package_id] + set user_id [ad_conn user_id] + + if { ![db_0or1row km_check_object_type_id " + select deleted_p, browse_p, public_p, + decode([tcl_permission_p ":package_id" ":user_id" "'admin'"],'t',1,0) as admin_p, + decode([tcl_permission_p ":object_type_id" ":user_id" "'create'"],'t',1,0) as create_p + from sn_object_types + where object_type_id = :object_type_id + and context_id = :package_id + "] } { + if { $print_errors_p } { + ad_return_exception_page 404 "Invalid object_type_id" \ + "The given object_type_id is invalid." + } + return 0 + } + + km_conn -reset + km_conn -set admin_p $admin_p + km_conn -set create_p $create_p + + if { $deleted_p == "t" } { + if { $print_errors_p } { + ad_return_exception_page 410 "Object type no longer exists" \ + "This object type has been removed from the system." + } + return 0 + } + + if { $check_view_p && $public_p == "f" && !$admin_p } { + if { $print_errors_p } { + ad_return_forbidden "Not Authorized" \ + "You are not authorized to view objects of this type." + } + return 0 + } + + if { $check_create_p && ($public_p == "f" || !$create_p) && !$admin_p } { + if { $print_errors_p } { + ad_return_forbidden "Not Authorized" \ + "You are not authorized to create objects of this type." + } + return 0 + } + + return 1 +} + +ad_proc km_check_owner_change { + { + -print_errors_p 1 + } + object_id +} { + + Checks if the user may change the ownership of the given + object. This is only allowed for the object owner and administrators. + +} { + set user_id [ad_conn user_id] + set package_id [ad_conn package_id] + + set result [db_string check_owner_change " + select decode(count(*),0,0,1) from dual where exists + (select 1 + from sn_objects + where object_id = :object_id + and context_id = :package_id + and (original_author_id = :user_id or + [tcl_permission_p ":package_id" ":user_id" "'admin'"] = 't')) + "] + + if { !$result && $print_errors_p } { + ad_return_forbidden "Not Authorized" \ + "You are not authorized to change the ownership of this object." + } + + return $result +} + +proc_doc km_object_type_private_p {object_type_id} { + Checks if an object type is not visible to the public. +} { + set context_id [ad_conn package_id] + set result [db_string km_object_type_private_p " + select decode(public_p,'t',0,1) + from sn_object_types where object_type_id=:object_type_id" -default ""] + + return $result +} Index: openacs-4/contrib/obsolete-packages/library/tcl/km-admin-lib-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/tcl/km-admin-lib-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/tcl/km-admin-lib-procs.tcl 2 Jul 2003 12:19:41 -0000 1.1 @@ -0,0 +1,161 @@ +ad_proc km_db_1row_to_list { statement_name sql args } { + + Performs the SQL query $sql. Returns a list of the results. + +} { + ad_arg_parser { bind } $args + + # Query Dispatcher (OpenACS - ben) + set full_statement_name [db_qd_get_fullname $statement_name] + + db_with_handle db { + set selection [db_exec 0or1row $db $full_statement_name $sql] + } + + if { [empty_string_p $selection] } { + return "" + } + + set list_to_return "" + + for { set i 0 } { $i < [ns_set size $selection] } { incr i } { + lappend list_to_return [ns_set value $selection $i] + } + + + for { set i 0 } { $i < [ns_set size $selection] } { incr i } { + upvar 1 [ns_set key $selection $i] value + set value [ns_set value $selection $i] + } + + return $list_to_return +} + +ad_proc km_db_to_named_list_list { statement_name sql args} { + Returns a list of Tcl lists, with each sublist containing the columns returned + by the database; if no rows are returned by the database, returns the + empty list (empty string in Tcl 7.x and 8.x)" +} { + ad_arg_parser { bind } $args + + # Query Dispatcher (OpenACS ) + set full_statement_name [db_qd_get_fullname $statement_name] + + db_with_handle db { + set selection [db_exec select $db $full_statement_name $sql] + + set keys [list] + for {set i 0} {$i<[ns_set size $selection]} {incr i} { + lappend keys [ns_set key $selection $i] + } + set list_to_return [list $keys] + while {[ns_db getrow $db $selection]} { + set row_list "" + set size [ns_set size $selection] + set i 0 + while {$i<$size} { + lappend row_list [ns_set value $selection $i] + incr i + } + lappend list_to_return $row_list + } + } + + return $list_to_return +} + +proc_doc km_new_acs_object_id {} { + Returns a new acs_object_id +} { + set result [db_string km_new_acs_object_id "select acs_object_id_seq.nextval from dual"] + return $result +} + +proc_doc km_sort_key_list { object_type_id } { + + Returns a list of sort_keys available for this object_type + (sort_keys are offered as increments of 10 and should *NEVER* be + the same for 2 questions of one object_type) + +} { + set result "" + set existing_keys [db_list km_sort_key_list "select sort_key from + sn_question_object_type_map + where object_type_id=$object_type_id"] + set i 0 + while { $i < 400 } { + + set i [expr $i + 10] + if {[elem_p $i $existing_keys]} { + continue + } else { + lappend result $i + } + } + return $result +} + +ad_proc km_adt_list { { -pretty_names_p 0 } } { + Returns a list of abstract data types as a list or as a list of tuples + with the pretty name as the second element. +} { + set adts { + text option category other_category integer date file composite + object_link user_link content_link child_object nephew_object + other_category + } + set pretty_names { + Text "Multiple Choice" Category "Category with 'Other' field" Number Date File + Composite "Object-Object Link" "Object-User Link" "Object-Content Link" + "Child Object Type" "Nephew Object Type" + + } + + if { $pretty_names_p } { + return [zip $adts $pretty_names] + } else { + return $adts + } +} + +proc_doc km_pretty_adt { abstract_data_type } { + Returns the pretty abstract data type +} { + switch $abstract_data_type { + "text" { return Text } + "option" { return "Multiple Choice" } + "category" { return "Category" } + "other_category" { return "Category with 'Other' field" } + "date" { return "Date" } + "file" { return "Attachment" } + "composite" { return "Composite" } + "object_link" { return "Object Link" } + "user_link" { return "User Link" } + "content_link" { return "Content Link" } + "child_object" { return "Child Object Type" } + "nephew_object" { return "Nephew Object Type" } + "integer" { return "Number" } + default { return} + } +} + + +proc_doc km_pretty_tag { presentation_type } { + Returns the pretty tag name +} { + switch $presentation_type { + "shorttext" { return "Short Text" } + "text" { return "Short Text" } + "textarea" {return "Textarea" } + "textarea_with_refs" {return "Textarea with Reference Buttons"} + "select" { return Select} + "selectmultiple" {return "Select Multiple" } + "checkbox" {return "Checkbox"} + "radio" {return "Radio Buttons"} + "custom" { return "Custom"} + "application" { return "Application Form"} + default { return } + } +} + + Index: openacs-4/contrib/obsolete-packages/library/tcl/km-branch-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/tcl/km-branch-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/tcl/km-branch-procs.tcl 2 Jul 2003 12:19:41 -0000 1.1 @@ -0,0 +1,319 @@ +# /tcl/km-branch.tcl +# +# These procs have to do with the branches to questions. Branches are +# answer-dependent questions that follow other questions. +# +# $Id: km-branch-procs.tcl,v 1.1 2003/07/02 12:19:41 peterm Exp $ + +ad_proc km_get_branches { + { + -question_attributes_p 0 + -branch_id 0 + } + root_question_id + object_type_id +} { + Returns a list of the question_ids directly beneath this question_id in the branch tree. If + this question is not a branched question then it returns nothing. +} { + + set join_tables [list "sn_question_object_type_map m1" "sn_question_object_type_map m2"] + set join_clause "" + set columns "" + set limitation "" + + if { $question_attributes_p } { + + # We need to know the abstract_data_type of the parent question to know + # if the answer is stored as an option or as a foreign key in the branch recipe. + + set abstract_data_type [thd [km_get_question $root_question_id $object_type_id]] + + switch $abstract_data_type { + "integer" - + "text" { + append columns ", m1.branch_answer branch_answer" + } + "category" - "other_category" { + append columns ",c.category_id, c.long_name branch_answer" + lappend join_tables "categories c" + append join_clause " and m1.branch_answer_foreign_key = c.category_id(+)" + } + "option" { + append columns ", ao.option_id, ao.answer_option branch_answer" + lappend join_tables "sn_answer_options ao" + append join_clause " and m1.branch_answer_foreign_key = ao.option_id(+)" + } + default { return } + } + lappend join_tables " sn_questions q" + append join_clause " and q.question_id = m1.question_id" + append columns ", m1.branch_operator, pretty_name, q.entry_explanation, q.presentation_type, q.abstract_data_type" + } + if { $branch_id } { set limitation " and m1.question_id = :branch_id " } + + set sql "select m1.question_id $columns from [join $join_tables ","] + where m2.question_id = m1.parent_question_id + and m1.branch_p = 't' + and m1.object_type_id = :object_type_id + and m1.parent_question_id = :root_question_id + $join_clause $limitation" + set result [km_db_to_named_list_list km_get_branches $sql] + return $result +} + +proc_doc km_default_branch { root_branch_id } { + Returns the default branch of a branch node. +} { + set default_branch [db_string km_default_branch " + select default_branch + from sn_question_object_type_map qm + where question_id=$root_branch_id + and (select qm2.branch_p + from sn_question_object_type_map qm2 + where qm2.question_id = qm.default_branch) = 't'" -default ""] + + return $default_branch +} + +proc_doc km_branch_parent { question_id object_type_id } { + Returns the parent_question_id of this question iff this is a branch. +} { + set result [db_string km_branch_parent " + select parent_question_id + from sn_question_object_type_map + where question_id=:question_id + and branch_p='t' + and object_type_id=:object_type_id" -default ""] + + return $result +} + +proc_doc km_composite_parent { question_id object_type_id } { + Returns the parent_question_id of this question if this is a composite child. +} { + set result [db_string km_composite_parent " + select parent_question_id + from sn_question_object_type_map + where question_id=:question_id + and branch_p='f' + and object_type_id=:object_type_id" -default ""] + if {$result == [km_static km_dummy_object_id]} { + return "" + } + return $result +} + +proc_doc km_get_root_branch { question_id object_type_id} { + Returns the id of the root question of this branch. +} { + set result [db_string km_get_root_branch " + select question_id + from sn_question_object_type_map + where question_id <> :question_id and branch_p='f' + start with question_id=:question_id and object_type_id=:object_type_id + connect by question_id = prior parent_question_id" -default ""] + + return $result +} + +proc_doc km_root_branch_p { question_id } { + Returns true if this question is a root of a branch (at any level) +} { + return [db_string km_root_branch_p { + select decode(count(*),0,0,1) from dual where exists + (select 1 + from sn_question_object_type_map + where parent_question_id = :question_id and branch_p='t') + }] +} + +proc_doc km_composite_child_p { question_id object_type_id } { + Returns 1 if this question is the child of a composite question, 0 otherwise. + Included here because the distinction between branches and composite children is slight. +} { + set result [db_string km_composite_child_p " + select decode(parent_question_id,[km_static km_dummy_object_id],0,1) + from sn_question_object_type_map + where branch_p='f' + and question_id=:question_id + and object_type_id=:object_type_id" -default "0"] + + return 0 +} + +proc_doc km_active_branch_path { root_question_id object_id object_type_id } { + + Returns the sequence of questions after this root branch question that + are part of the active branch path for this object. + +} { + set branch_id $root_question_id + set branch_list {} + if ![km_root_branch_p $root_question_id] { return $branch_list } + + # Loop through hierarchy until we reach a leaf node or an unanswered question. + set i 0 + while { 1 == 1 } { + # Get object data for the branch_id. + set question [km_get_question $branch_id $object_type_id] + if [empty_string_p $question] { + ns_log Error "Question $branch_id not found in km_active_branch_path" + return + } + + set answer [fst [km_get_object_data -answers_only_p 0 -questions [list {question_id pretty_name abstract_data_type} $question] $object_id]] + set value [fst $answer] + set abstract_data_type [lindex $answer 3] + + # Append this question to the list + lappend branch_list $branch_id + + if ![km_answered_p $abstract_data_type $value] { + # the answer is empty so return the list + return $branch_list + } else { + # Get next branch + set branch_id [km_next_branch -abstract_data_type $abstract_data_type $branch_id $value $object_type_id] + if [empty_string_p $branch_id ] { return $branch_list } + } + + incr i + if { $i > 100 } { + ns_log Error "Endless loop in km_active_branch_path" + return + } + } +} + +proc_doc km_active_path_p { question_id object_id object_type_id } { + + Returns 1 if this question is on an active branch path or is not on a branch at all. + Returns 0 if this question is not on a central branch path (i.e. it is decoupled + from the normal question sequence) + +} { + set root_question_id [km_get_root_branch $question_id $object_type_id] + if [empty_string_p $root_question_id] { return 1 } + + set active_branches [km_active_branch_path $root_question_id $object_id $object_type_id] + if [elem_p $question_id $active_branches] { + return 1 + } else { + return 0 + } +} + +ad_proc km_next_branch { { -abstract_data_type "" } root_branch_id answer object_type_id } { + + Returns the question_id that should follow this question as a result of + the answers. It returns the default question if the answer hasn't been matched or is empty. + If it can't figure out the next question it returns nothing. + +} { + if [empty_string_p $abstract_data_type] { + set abstract_data_type [km_static question_abstract_data_type $root_branch_id] + } + + # If it's not one of these abstract data types then this proc should never have been called! + if { [lsearch {"category" "other_category" "option"} $abstract_data_type] >= 0 } { + + # Data answers are always tuples - we need the first value of the first pair + set answer [fst [fst $answer]] + + # Then the answer is the integer value of the option, a foreign key + set column "branch_answer_foreign_key" + + if { [empty_string_p $answer] || ![integer_p $answer] } { return } + + } elseif { [lsearch {"text" "integer"} $abstract_data_type] >= 0 } { + set column "branch_answer" + set answer [fst $answer] + if { [empty_string_p $answer] || ![integer_p $answer] } { return } + } else { + return "" + } + + set default_branch [km_default_branch $root_branch_id] + + set branches [db_list_of_lists km_next_branch " + select question_id, branch_operator, $column + from sn_question_object_type_map + where parent_question_id=$root_branch_id + and object_type_id=$object_type_id"] + + # Go through each of the branches and see if the operator matches this value + foreach branch $branches { + set branch_id [fst $branch] + set operator [snd $branch] + set branch_answer [thd $branch] + + if [eval_binary $operator $answer $branch_answer] { return $branch_id } + } + + return $default_branch +} + +proc km_pretty_operator { operator } { + switch $operator { + "=" { return "Equals =" } + "<" { return "Less Than <" } + ">" { return "Greater Than >" } + default { return } + } +} + +ad_proc km_branch_questions { + { + -branch_id 0 + -all_properties_p 1 + -root_question_id 0 + -composite_children_p 1 + } + object_type_id +} { + + This proc returns keyed question lists with attributes on the basis of variable branch + properties. i.e. It can return a list that shows all questions of an object_type that + are NOT branches, or these plus the one that IS this branch_id. + + This proc has become more a general admin questions list, since it can do some stuff + for composite questions, too. + +} { + if { $all_properties_p } { + set additional_columns ",presentation_type, tag_height, tag_width, entry_explanation, qm.mandatory_p, qm.question_state, qm.form_number, qm.sort_key " + } + + set limitation "parent_question_id=[km_static km_dummy_object_id] and question_state <> 'invisible'" + set counter 1 + + if { $root_question_id } { + append limitation " and qm.question_id != :root_question_id" + incr counter + } + if { $branch_id } { + append limitation " or qm.question_id = :branch_id " + incr counter + } + if { $counter > 1 } { + set limitation " and ($limitation)" + } else { + set limitation " and $limitation" + } + if { $composite_children_p } { + append limitation " +and q.abstract_data_type in ('text', 'option', 'category', 'other_category', 'date', 'file', 'integer', 'object_link', 'content_link', 'user_link', 'child_object', 'nephew_object') +and q.question_id not in (select parent_question_id from sn_question_object_type_map where object_type_id=:object_type_id and branch_p='t')" + } + set result [km_db_to_named_list_list km_branch_questions " + select q.question_id, q.pretty_name, q.abstract_data_type + $additional_columns + from sn_questions q, sn_question_object_type_map qm + where q.question_id=qm.question_id + and qm.object_type_id = :object_type_id + $limitation + order by qm.sort_key"] + + return $result +} Index: openacs-4/contrib/obsolete-packages/library/tcl/km-browse-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/tcl/km-browse-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/tcl/km-browse-procs.tcl 2 Jul 2003 12:19:41 -0000 1.1 @@ -0,0 +1,375 @@ +# /tcl/km-browsing.tcl +# +# Browsing of knowledge objects. +# Created by carsten@arsdigita.com in June 2000 +# +# $Id: km-browse-procs.tcl,v 1.1 2003/07/02 12:19:41 peterm Exp $ + +proc_doc km_ancestors_context_list {ancestors {category_id ""} {pre_url ""}} { + + Get a list of links to the parent objects, plus a link + to the root parent's object type. + +} { + set root_object_id [fst [fst $ancestors]] + + db_1row get_root_info { + select o.one_line_description as ancestor_name, + o.object_type_id as ancestor_object_type_id, + ot.pretty_plural as ancestor_object_type, + o.archived_p as ancestor_archived_p + from sn_objects o, sn_object_types ot + where o.object_id = :root_object_id + and ot.object_type_id = o.object_type_id + } + + if {$ancestor_archived_p == "t"} { + set ancestor_object_type "$ancestor_object_type (Archived)" + set archive t + } + lappend result [list "${pre_url}browse-one-type?[export_vars [list [list object_type_id $ancestor_object_type_id] archive]]" $ancestor_object_type] + + if {![empty_string_p $category_id] && $category_id != "none"} { + if {[db_string is_object_of_category {select count(*) from sw_object_category_map where category_id = :category_id and object_id = :root_object_id}] > 0} { + lappend result [list "${pre_url}browse-one-category?[export_vars [list [list object_type_id $ancestor_object_type_id] category_id archive]]" [km_category_name $category_id]] + } + } + + foreach ancestor $ancestors { + set name [sn_striphtml [snd $ancestor]] + if {[empty_string_p $name]} { + set name "Unnamed [km_static object_type_pretty_name [thd $ancestor]]" + } + lappend result [list "${pre_url}object-view?object_id=[fst $ancestor]&category_id=$category_id" $name] + } + + return $result +} + +proc_doc km_sort_by_bar { sort_by child_type_p } { + Sort: Object name | Modification date +} { + set sort_by_list {{name "name"} {last_modified "modification date"}} + lappend sort_by_list {average_rating "user rating"} + if { $child_type_p } { lappend sort_by_list {parent "parent object"} } + + foreach sort_item $sort_by_list { + set sort_column [lindex $sort_item 0] + set sort_description [lindex $sort_item 1] + + if {$sort_column == $sort_by} { + lappend sort_text "$sort_description" + } else { + lappend sort_text "$sort_description" + } + } + + return "\[ [join [concat $sort_text] " | "] \]" +} + +proc_doc km_category_display_limit {} { + + If the object list contains more than this many objects, + no categorization will be shown. + +} { + return [ad_parameter CategoryDisplayLimit library 20] +} + +ad_proc km8_output_object_list { + { + -object_type_id 0 + -header "" + -current_action "" + -path_id "" + -pool all + -age all + -sort_by "" + -show short + -category_id "" + -question_id 0 + -where_clauses {} + -minus_join_tables {} + -minus_where_clauses {} + -first_row 0 + -last_row 0 + -begin_letter "" + -archived "f" + -start_date "" + -end_date "" + -more_join_tables {} + } +} { + + Output a list of objects. + +} { + ! Entered km8_output_object_list +more_join_tables + set user_id [ad_conn user_id] + set package_id [ad_conn package_id] + set instance_read_p [ad_permission_p $package_id "read"] + + template::multirow create object_list public_p archived_p review_p object_view_link object_name user_link last_modified number_ratings rating_avg rating_avg_img rating_max rating_max_img access_total access_month overview categories_html + + set child_type_p [db_string km_output_object_list_1 " + select decode(count(*),0,0,1) from sn_questions + where abstract_data_type in ('child_object','nephew_object') + and target_object_type_id = :object_type_id"] + + # If the user is linking, or adding a SN reference, + # we add a button to each object. + + # Make sure the user cannot see expired or private objects. + # Exceptions: Administrators, Sharenet Managers, and users who have been granted + # view permission for the object. + + set join_tables [list "sn_objects obj"] + + set package_id [ad_conn package_id] + lappend where_clauses \ + "obj.expiration_date > sysdate" \ + "obj.object_type_id = :object_type_id" \ + "obj.context_id = :package_id" \ + "obj.archived_p = :archived" + + if { !$instance_read_p && $pool == "all" } { + # Only count published objects, or objects for which the user + # has view permission. + + # Note that we only check direct read permission on flat + # groups and users. Since the context_id of private objects is + # NULL, and we only grant permissions to private groups, this + # is sufficient. + + lappend where_clauses \ + "(obj.public_p = 't' or obj.object_id in ( + select object_id from acs_permissions + where (grantee_id = :user_id + or grantee_id in (select group_id from membership_rels + where person_id = :user_id)) + and privilege = 'read'))" + } + + if { [string compare $age all] != 0 } { + # Filter by time of last modification. + lappend where_clauses "sysdate - obj.last_modified < :age" + } + + # Filter by author and co-owners. + switch $pool { + own { lappend where_clauses "obj.original_author_id = :user_id" } + coown { + lappend join_tables "acs_permissions p" + + lappend where_clauses \ + "obj.object_id = p.object_id" \ + "p.privilege = 'write'" \ + "(p.grantee_id = :user_id + or p.grantee_id in (select group_id from membership_rels where person_id = :user_id))" + } + } + + # Sort by time of last modification or by name. + set columns {1} + switch $sort_by { + average_rating { + set sort_by_clause "nvl(cr.rating_sum,0) / nvl(cr.rating_count,1) desc, obj.last_modified desc" + set sort_by_clause2 "rating_avg desc, last_modified desc" + } + last_modified { + set sort_by_clause "obj.last_modified desc, lower(obj.one_line_description)" + set sort_by_clause2 "last_modified desc, lower(name)" + } + name { + set sort_by_clause "lower(obj.one_line_description), obj.last_modified desc" + set sort_by_clause2 "lower(name), last_modified desc" + } + parent { + set sort_by_clause "lower(obj2.one_line_description), lower(obj.one_line_description), obj.last_modified desc" + set sort_by_clause2 "lower(parent_name), lower(name), last_modified desc" + + lappend columns "obj2.one_line_description as parent_name" + lappend join_tables "km_flat_object_hierarchy fo" "sn_objects obj2" + lappend where_clauses \ + "fo.child(+) = obj.object_id" \ + "(fo.distance = 1 or fo.distance is null)" \ + "fo.parent = obj2.object_id(+)" + } + default { + set sort_by_clause "$sort_by, obj.last_modified desc" + set sort_by_clause2 "$sort_by, last_modified desc" + } + } + + if { ![string equal $begin_letter all] } { + if { ![string equal $begin_letter other] } { + lappend where_clauses "substr(upper(obj.one_line_description),1,1) = '[string toupper $begin_letter]'" + } else { + lappend where_clauses "(substr(upper(obj.one_line_description),1,1) < 'A' or substr(upper(obj.one_line_description),1,1) > 'Z')" + } + } + + if { ![empty_string_p $start_date] && ![empty_string_p $end_date]} { + lappend where_clauses "obj.start_date <= :end_date" "obj.end_date >= :start_date" + } + + set join_tables [concat $join_tables $more_join_tables] + + # We first need to get the number of listed objects, because + # depending on this number, we will or will not display object + # categorization. + + ! Get the number of listed objects + set num_found_objects [db_string count_all_objects " + select count(unique obj.object_id) + from [join $join_tables ", "] + where [join $where_clauses "\nand "]"] + ! Got the number of listed objects +num_found_objects + + if { ![null_p $minus_join_tables] } { + ! Get the number of excluded objects + set num_excluded_objects [db_string count_excluded_objects " + select count(unique obj.object_id) + from [join [concat $join_tables $minus_join_tables] ", "] + where [join [concat $where_clauses $minus_where_clauses] "\nand "]"] + ! Got the number of excluded objects +num_excluded_objects + + set num_found_objects [expr $num_found_objects - $num_excluded_objects] + } + + if { $child_type_p } { + lappend columns "km_utilities.km_ancestor_list(obj.object_id) as ancestors" + } + + set display_limit [km_category_display_limit] + set category_questions {} + if { $num_found_objects < $display_limit } { + # Get node_id, category, question_id, question_pretty_name. + set category_questions [km_node_question_list $object_type_id] + + foreach category_tuple $category_questions { + set root_node_id [fst $category_tuple] + lappend columns "km_utilities.km_category_list(obj.object_id, $root_node_id) as cat$root_node_id" + } + } + + if { [null_p $minus_join_tables] } { + set sql " + select * from (select obj.object_id, + decode(obj.public_p,'t',1,0) as public_p, + decode(obj.archived_p,'t',1,0) as archived_p, + decode(obj.in_review_p,'t',1,0) as review_p, + u.first_names || ' ' || u.last_name as owner, u.user_id as owner_id, + obj.one_line_description as name, obj.overview, + decode(obj.overview_html_p,'t',1,0) as overview_html_p, + obj.last_modified, nvl(obj.access_total,0) as access_total, + nvl(obj.access_month,0) as access_month, + round(nvl(cr.rating_sum,0) / nvl(cr.rating_count,1),1) as rating_avg, + nvl(cr.rating_max,0) as rating_max, + nvl(cr.rating_count,0) as number_ratings, + dense_rank() over (order by $sort_by_clause) dr, + [join $columns ", "] + from [join $join_tables ", "], sn_comments_ratings cr, users u + where u.user_id = obj.original_author_id + and cr.object_id(+) = obj.object_id + and [join $where_clauses "\nand "]) + where dr >= :first_row and (:last_row = 0 or dr <= :last_row) + order by $sort_by_clause2" + } else { + # This will be a bit complicated. We were called from browse-one-category + # to display a list of uncategorized objects. The fastest way to do this + # is with a MINUS, using only the object_id column. We then join the result + # with the query we would normally use to get the data we want. + + set sql " +select * from (select obj.object_id, + decode(obj.public_p,'t',1,0) as public_p, + decode(obj.archived_p,'t',1,0) as archived_p, + decode(obj.in_review_p,'t',1,0) as review_p, + u.first_names || ' ' || u.last_name as owner, u.user_id as owner_id, + obj.one_line_description as name, obj.overview, + decode(obj.overview_html_p,'t',1,0) as overview_html_p, + obj.last_modified, nvl(obj.access_total,0) as access_total, + nvl(obj.access_month,0) as access_month, + round(nvl(cr.rating_sum,0) / nvl(cr.rating_count,1),1) as rating_avg, + nvl(cr.rating_max,0) as rating_max, + nvl(cr.rating_count,0) as number_ratings, + dense_rank() over (order by $sort_by_clause) dr, + [join $columns ", "] +from [join $join_tables ", "], sn_comments_ratings cr, users u, + (select obj.object_id + from [join $join_tables ", "] + where [join $where_clauses "\nand "] + minus + select /*+ORDERED*/ obj.object_id + from [join [concat $join_tables $minus_join_tables] ", "] + where [join [concat $where_clauses $minus_where_clauses] "\nand "]) filtered +where u.user_id = obj.original_author_id + and cr.object_id(+) = obj.object_id + and obj.object_id = filtered.object_id) +where dr >= :first_row and (:last_row = 0 or dr <= :last_row) +order by $sort_by_clause2" + } + + # We pass use a path to pass a couple of values to object-view, + # so they can be used as return URLs. (This is important because + # we want to preserve the user's filter and sort settings.) + + set value_list [list browse_type [export_url_vars pool age sort_by show begin_letter]] + set parameters "" + if { ![empty_string_p $category_id] } { + set value_list [concat $value_list [list browse_category [export_url_vars pool age sort_by show begin_letter question_id column_name]]] + set parameters "&category_id=$category_id" + } + set new_path_id [init_path -last_path_id $path_id $value_list "" "browse"] + + ! Getting the object list + set old_rank "0" + db_foreach get_object_list $sql { + ## filter out duplicate rows with the same dense_rank than the row + ## before + if {$dr == $old_rank} { + continue + } + set old_rank $dr + set categories_html "" + + # Display the object's parent. + if { $child_type_p && ![empty_string_p $ancestors] } { + append categories_html "Related Objects: " + foreach ancestor $ancestors { + append categories_html "[snd $ancestor]; " + } + set categories_html [string range $categories_html 0 end-2] + } + + if { $num_found_objects <= $display_limit && ![null_p $category_questions] } { + # List the object's categories. + foreach category_pair $category_questions { + set root_node_id [fst $category_pair] + set question_name [lindex $category_pair 3] + set category_value [set cat$root_node_id] + + if ![empty_string_p $category_value] { + if ![empty_string_p $categories_html] { append categories_html "; " } + append categories_html "$question_name: $category_value" + } + } + } + + if ![empty_string_p $overview] { + set overview [util_trim_string_with_hrefs [sn_striphtml $overview]] + } + + if [empty_string_p $name] { + set name "Unnamed [km_static object_type_pretty_name $object_type_id]" + } + + set object_view_link "object-view?object_id=$object_id$parameters&path_id=$new_path_id" + template::multirow append object_list $public_p $archived_p $review_p $object_view_link [sn_striphtml $name] [ad_present_user $owner_id $owner] [util_AnsiDatetoPrettyDate $last_modified] $number_ratings $rating_avg [gf_feedback_points_img $rating_avg 5] $rating_max [gf_feedback_points_img $rating_max 5] $access_total $access_month $overview $categories_html + } + ! Got the object list + + ! Exiting km8_output_object_list + return $num_found_objects +} Index: openacs-4/contrib/obsolete-packages/library/tcl/km-callback-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/tcl/km-callback-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/tcl/km-callback-procs.tcl 2 Jul 2003 12:19:41 -0000 1.1 @@ -0,0 +1,200 @@ +# /tcl/km-callback-procs.tcl +# +# Procs called from other modules. +# +# @author Carsten Clasohm (carsten@arsdigita.de) +# @creation-date 2001-10-10 +# @cvs-id $Id: km-callback-procs.tcl,v 1.1 2003/07/02 12:19:41 peterm Exp $ + +ad_proc -public library_post_instantiation { + package_id +} { + This is the TCL proc that is called automatically by the APM + whenever a new instance of the application is created. +} { + sn_community::grant_role_permissions $package_id { + maintainer {access create km_publish} + member {access create} + guest {access} + } + db_exec_plsql create_magic_psn_category_objects { + begin + psn_res_application.create_magic_objects ( + package_id => :package_id + ); + end; + } +} + +ad_proc -public library_supported_privileges {} { + + Returns a list of instance-level privileges supported by the Library. + Used by sn-communities to set permissions for role groups. + +} { + return { + {admin "Administer"} + {access "Access"} + {create "Create new objects"} + {read "Read private objects"} + {write "Edit all objects"} + {delete "Delete all objects"} + {km_publish "Publish an object if approval process is true"} + } +} + +ad_proc -public library_copy_data {source_package_id target_package_id} { + Copy object type structure to the target package. +} { + set ip_address [ns_conn peeraddr] + set user_id [ad_get_user_id] + + db_exec_plsql copy_all_object_types { + begin + library.copy ( + src_package_id => :source_package_id, + dst_package_id => :target_package_id, + creation_user => :user_id, + creation_ip => :ip_address); + end; + } +} + +ad_proc -public library_get_category_trees {package_id} { + + Returns a list of all category trees used by this instance. + Used during community copying, to grant permissions on the trees. + +} { + + return [db_list get_categories { + -- Categories used for object type questions. + select tree_id + from sn_object_types ot, sn_question_object_type_map qm, sn_questions q + where ot.context_id = :package_id + and qm.object_type_id = ot.object_type_id + and q.question_id = qm.question_id + and q.abstract_data_type in ('category', 'other_category') + and q.tree_id is not null + union + -- Categories used for object feedback. + select object_id_two + from acs_rels + where rel_type = 'object_category_tree_rel' + and object_id_one = :package_id + union + -- Categories used on the PeopleShareNet application form. + select object_id_two + from acs_rels r, psn_category_trees ct + where r.rel_type = 'object_category_tree_rel' + and ct.package_id = :package_id + and (r.object_id_one = ct.role_magic_id + or r.object_id_one = ct.language_magic_id + or r.object_id_one = ct.proficiency_magic_id) + + }] + +} + +namespace eval categories::packages::library { + ad_proc -public get_instances { tree_id } { + Returns a list of all library instances using a certain category tree + } { + set instance_list [list] + set user_id [ad_conn user_id] + + db_foreach get_library_instances_for_tree { + select v.object_id, p.instance_name, v.object_name, + ci.community_id, p2.instance_name as community_name, + acs_permission.permission_p(p.package_id, :user_id, 'access') as show_p + from apm_packages p, apm_packages p2, sn_community_instances_all ci, + (select distinct q.question_id, ot.object_type_id as object_id, + ot.pretty_plural || ' (Question "' || q.pretty_name || '")' as object_name, + ot.context_id as package_id + from sn_object_types ot, sn_questions q, + sn_question_object_type_map qm, sw_category_dim d + where d.parent_node_id = q.node_id + and d.tree_id = :tree_id + and q.question_id = qm.question_id + and qm.object_type_id = ot.object_type_id + union + select 0 as question_id, p.package_id as object_id, + 'Feedback' as object_name, p.package_id + from acs_rels r, apm_packages p + where r.object_id_two = :tree_id + and r.rel_type = 'object_category_tree_rel' + and r.object_id_one = p.package_id + and p.package_key = 'library') v + where p.package_id = v.package_id + and ci.package_id = v.package_id + and p2.package_id = ci.community_id + order by p2.instance_name, p.instance_name, v.object_name + } { + lappend instance_list [list Libraries $object_id $object_name $instance_name $community_id $community_name $show_p $show_p] + } + return $instance_list + } +} + +namespace eval sn_presentation::types::sn_object { + ad_proc linkable_item {object_id url object_data_var} { + upvar 1 $object_data_var object_data + + set public_p 0 + if { [string first "presentation=public" $object_data(presentation)] != -1 } { + set public_p 1 + } + set archived_p 0 + if { [string first "archived" $object_data(presentation)] != -1 } { + set archived_p 1 + } + set in_review_p 0 + if { [string first "in_review" $object_data(presentation)] != -1 } { + set in_review_p 1 + } + + set result "[sn_striphtml $object_data(name)]" + if { !$public_p } { append result " \[Private\]" } + if { $archived_p } { append result " \[Archived\]" } + if { $in_review_p } { append result " \[In review\]" } + return $result + } + + ad_proc item {object_id object_data_var} { + upvar 1 $object_data_var object_data + + set public_p 0 + if { [string first "presentation=public" $object_data(presentation)] != -1 } { + set public_p 1 + } + set archived_p 0 + if { [string first "archived" $object_data(presentation)] != -1 } { + set archived_p 1 + } + set in_review_p 0 + if { [string first "in_review" $object_data(presentation)] != -1 } { + set in_review_p 1 + } + + set result [sn_striphtml $object_data(name)] + if { !$public_p } { append result " \[Private\]" } + if { $archived_p } { append result " \[Archived\]" } + if { $in_review_p } { append result " \[In review\]" } + return $result + } +} + +namespace eval alerts { + namespace eval types { + namespace eval sn_object { + ad_proc -public get_object {object_id} { + } { + if { [catch { set object_as_clob [db_string object_public_object_clob \ + {select site_wide_search.indexed_content(:object_id) from dual}]} errmsg] } { + return [list "" 0] + } + return [list $object_as_clob 0] + } + } + } +} Index: openacs-4/contrib/obsolete-packages/library/tcl/km-categories-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/tcl/km-categories-procs.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/tcl/km-categories-procs.tcl 2 Jul 2003 12:19:41 -0000 1.1 @@ -0,0 +1,876 @@ +# /tcl/km-categories.tcl +# +# Categorization of knowledge objects. +# +# Created by carsten@arsdigita.com in June 2000 +# +# Modified by tvujec@arsdigita.com in August 2001 +# +# $Id: km-categories-procs.tcl,v 1.1 2003/07/02 12:19:41 peterm Exp $ + +# Category hierarchy +# +# location
+ if { [regsub -all "\015\012\015\012" $text "
" text] == 0 } { + # try LFLF + if { [regsub -all "\012\012" $text "
" text] == 0 } { + # try CRCR + regsub -all "\015\015" $text "
" text
+ }
+ }
+ # turn CRLF into
+ if { [regsub -all "\015\012" $text "
" text] == 0 } {
+ # try LF
+ if { [regsub -all "\012" $text "
" text] == 0 } {
+ # try CR
+ regsub -all "\015" $text "
" text
+ }
+ }
+ # Dress the links and emails with A HREF
+ regsub -all {([]!?.:;,<>\(\)\}-]+)(eNdUrL )} $text {\2\1} text
+ regsub -all {([]!?.:;,<>\(\)\}-]+)(eNdEmAiL )} $text {\2\1} text
+ regsub -all { sTaRtUrL([^ ]*)eNdUrL } $text {\1} text
+ regsub -all { sTaRtEmAiL([^ ]*)eNdEmAiL } $text {\1} text
+ return [string trimleft $text]
+}
+
+proc_doc library_icon_height {} "Returns the height for an object icon" {
+ return "50"
+}
+
+proc_doc library_icon_width {} "Returns the width for an object icon" {
+ return "50"
+}
+
+ad_proc space {{-size 20}} "returns an html space" {
+
+ set space ""
+ set i 0
+ while { $i < $size } {
+ append space " "
+ incr i
+ }
+ return $space
+
+}
Index: openacs-4/contrib/obsolete-packages/library/tcl/km-feedback-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/tcl/km-feedback-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/tcl/km-feedback-procs.tcl 2 Jul 2003 12:19:41 -0000 1.1
@@ -0,0 +1,165 @@
+# /tcl/km-feedback.tcl
+#
+# General comment system adapted to KM.
+#
+# Created by carsten@arsdigita.com in June 2000
+# modified by bernd@arsdigita.com in Jan. 2001
+#
+# ported by dirk@arsdigita.com in July 2001
+
+proc_doc km_check_comment_id { user_id comment_id } {
+
+ Checks if the user may edit the comment. If not, 0 is returned.
+ If he has edit permission, the associated object_id is returned.
+
+} {
+ if {![db_0or1row km_check_comment_id_10 {
+ select object_id, user_id as comment_user_id
+ from sn_comments where comment_id = :comment_id
+ }] } {
+ ad_return_exception_page 404 "" \
+ "The entry $comment_id does not exist in table general_comments."
+ return 0
+ }
+
+ if ![km_check_object_id $object_id] { return 0 }
+
+ if { $user_id != $comment_user_id && ![km_conn admin_p] } {
+ ad_return_complaint 1 "
-
+
- Hit 'Start task' +
- Clarify the Knowledge Object. Click here to look at it +
- Hit 'Task done' +
-
+
- Hit 'Start task +
- Check to see if the object needs to be clarified. Click here to look at it +
- Select the appropriate answer, add a comment and hit 'Task done' +
-
+
- Hit 'Start task' +
- Verify that the result is as you expected. +
- If it is, select 'yes' at the right. +
- If not, select 'no' at the right. +
- Hit 'Task done' +
-
+
- A valid URL would be something like http://photo.net/philg/, +
- A valid E-mail address would be something like: philg@mit.edu. +
+ View items modified in the last @age_bar;noquote@ +
+
| @categorization_widget_header.header_name@ | +
|---|
+
|
+
+
+
View items modified in the last @age_bar;noquote@ +
| View: | @object_view_bar_top_level;noquote@ + + Status: | @archive_bar;noquote@ | |
| Owner: | @ownership_bar;noquote@ | ||
| Alphabet: | [
+ |
No objects here. + +
| View: | @object_view_bar_top_level;noquote@ + + Status: | @archive_bar;noquote@ | |
| Owner: | @ownership_bar;noquote@ | ||
| Sort: | @object_sort_bar;noquote@ | ||
| Alphabet: | [
+ |
@pretty_type_plural;noquote@
+
+ @first_row@-@last_row@ of @num_displayed_objects@
+
+ (@num_displayed_objects@)
+
+
+ -
+
-
+
+ [Private] + ++ [Archived] + ++ [In review] + + @object_list.object_name@ + by @object_list.user_link;noquote@ (@object_list.last_modified@) + ++ (@object_list.access_total@ hits, @object_list.access_month@ this month) + + ++ (@object_list.number_ratings@ user + rating + +s: average of : +@object_list.rating_avg@ ) ++ + +
@object_list.overview@ ++ + +
(@object_list.categories_html;noquote@) +
+View items modified in the last @age_bar;noquote@ +
+
+
| @categorization_widget_header.header_name@ | +
|---|
+
|
+
+
+ No objects here.
+
+
+
+ View:
+ @object_view_bar_top_level;noquote@
+
+ Status: @archive_bar;noquote@ Owner: @ownership_bar;noquote@ Alphabet: [
+
+
+ View:
+ @object_view_bar_top_level;noquote@
+
+ Status: @archive_bar;noquote@ Owner: @ownership_bar;noquote@ Status: @archive_bar;noquote@ Owner: @ownership_bar;noquote@ Sort: @object_sort_bar;noquote@ Alphabet: [
+ @pretty_type_plural;noquote@
+
+
+
+
+
+
@object_list.overview@
+
(@object_list.categories_html;noquote@)
+
Index: openacs-4/contrib/obsolete-packages/library/www/comment-add-2.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/comment-add-2.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/comment-add-2.adp 2 Jul 2003 12:19:42 -0000 1.1
@@ -0,0 +1,86 @@
+
+
+
+@object_name@:
+@overview_with_href_and_mailto;noquote@
+
+@headline@
+
+
+
+ Please add a comment to your feedback. The system will include
+ it in the feedback E-Mail to the user.
+ Comment
+
Here you shall explain, describe or comment your feedback
+ (i.e. what project did you reuse the information for,
+ what did you learn, why do you think it's outdated or should have
+ more details, etc.).
| + + | +
+
+ |
|
+ + |
+ checked> +Add this comment as a public comment to the knowledge object +
+ ++++ +Feedback type: @feedback_category@
+Comment:
@comment;noquote@
+
+ Note: If the comment has lost all of its paragraph breaks then you
+ probably should have selected "Plain Text" rather than "HTML".
+ Note: If the comment has a bunch of visible HTML tags then you probably
+ should have selected "HTML" rather than "Plain Text". Use your
+ browser's Back button to return to the submission form.
+ You will receive the following shares:
+
+
+
+
+@object_name@:Index: openacs-4/contrib/obsolete-packages/library/www/comment-add.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/comment-add.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/comment-add.tcl 2 Jul 2003 12:19:42 -0000 1.1 @@ -0,0 +1,109 @@ +ad_page_contract { + /packages/library/www/comment-add.tcl + + Let the user choose a category for his feedback. + + @author Carsten Clasohm (carsten@arsdigita.com) + @author Timo Hentschel (timo@arsdigita.com) + + @cvs-id $Id: comment-add.tcl,v 1.1 2003/07/02 12:19:42 peterm Exp $ +} { + object_id:notnull,integer + {feedback_category_id:integer ""} + {category_id ""} + {path_id:integer ""} +} -properties { + title:onevalue + object_name:onevalue + object_type:onevalue + headline:onevalue + overview_with_href_and_mailto:onevalue + form_vars:onevalue + categories:multirow + author_id:onevalue + author_name:onevalue + feedback_category_id:onevalue + public_p:onevalue +} + +set user_id [ad_maybe_redirect_for_registration] +set package_id [ad_conn package_id] + +array set node [site_node_closest_ancestor_site_node "acs-subsite"] +set community_id $node(package_id) + +if ![km_check_object_id $object_id] { return } +set author_id [km_conn original_author_id] +set author_name [km_conn original_author_name] +set public_p [km_conn public_p] + +if {[km_conn archived_p]} { + ad_return_complaint 1 "Only feedback for not archived knowledge objects is allowed!" + return +} + +set object_name [km_conn object_name] +set object_type [km_static object_type_pretty_name [km_conn object_type_id]] + +set title "Give feedback for \"$object_name\"" +set headline "Give feedback" +set_the_usual_klib_context_bar $object_id $category_id +append_context_bar_data "Feedback category" +set overview_with_href_and_mailto [util_make_href_and_mailto_links [km_conn overview]] + +set form_vars [export_form_vars object_id path_id category_id] + +set feedback_category_tree_assigned_p [db_0or1row feedback_category_tree { + select gt.tree_name, octr.subtree_root_node_id, gt.root_node_id as original_root_node_id + from generic_trees gt, + acs_rels ar, + object_category_tree_rels octr + where ar.object_id_one = :package_id + and ar.object_id_two = gt.tree_id + and ar.rel_id = octr.rel_id + and rel_type = 'object_category_tree_rel'}] + +if { !$feedback_category_tree_assigned_p } { + ad_returnredirect "comment-add-2?[export_url_vars object_id path_id category_id]" + return +} else { + # get feedback categories + if { $subtree_root_node_id == $original_root_node_id } { + set level_correction 1 + } else { + set level_correction 0 + } + + template::multirow create categories name category_id level + + set sql_query " + select /*+INDEX(sw_category_dim sw_category_dim_long_name) */ category.long_name(object_id) as name, + object_id as category_id, deprecated_p, node_id, + level as sortlevel + from sw_category_dim + start with node_id = :subtree_root_node_id + connect by prior node_id = parent_node_id" + + # don't allow feedback categories with feedback points + # if user is author of the object or the object is private + if {($user_id == $author_id) || !$public_p} { + set sql_query " + select cat.name, cat.category_id, cat.deprecated_p, + cat.node_id, cat.sortlevel + from sn_comments_category_settings ccs, + ($sql_query) cat + where ccs.object_id = :package_id + and ccs.category_id (+) = cat.category_id + and nvl(ccs.rating_p,'f') = 'f'" + } + + db_foreach get_one_tree $sql_query { + if { [string equal $deprecated_p "f"]} { + if { $node_id!=$subtree_root_node_id || $subtree_root_node_id != $original_root_node_id } { + template::multirow append categories $name $category_id [gt_repeat_string " " [expr ($sortlevel - 1 -$level_correction) * 5]] + } + } + } +} + +ad_return_template Index: openacs-4/contrib/obsolete-packages/library/www/comment-delete-2.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/comment-delete-2.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/comment-delete-2.tcl 2 Jul 2003 12:19:42 -0000 1.1 @@ -0,0 +1,92 @@ +ad_page_contract { + /packages/library/www/comment-delete-2.tcl + + Allow the admin to delete feedback + + @author Timo Hentschel (timo@arsdigita.com) + + @cvs-id $Id: comment-delete-2.tcl,v 1.1 2003/07/02 12:19:42 peterm Exp $ +} { + comment_id:notnull,integer + {category_id ""} + {path_id ""} +} + +csrf::authenticate +set user_id [ad_maybe_redirect_for_registration] +set package_id [ad_conn package_id] +set object_id [km_check_comment_id $user_id $comment_id] +if !$object_id { return } + +set admin_p [km_conn admin_p] + +if {!$admin_p} { + ad_return_complaint 1 "Only admins can delete feedback!" + return +} + +set object_name [sn_striphtml [km_conn object_name]] +set object_type [km_static object_type_pretty_name [km_conn object_type_id]] + +set category_forward_email "" +set scale 0 + +set return_url "object-view?[export_url_vars object_id category_id path_id]" + +db_1row get_comment_data { + select sc.content, sc.html_p, c.long_name as feedback_category + from sn_comments sc, categories c + where comment_id=:comment_id + and sc.category_id = c.category_id(+) } + +db_transaction { + # remove the feedback from yellow pages + db_dml delete_content_area { + delete from acs_object_areas + where object_id = :comment_id + } + + # remove the feedback + db_exec_plsql delete_feedback { + begin + sn_comment.delete_comment ( :comment_id ); + end; + } + + if { $html_p == "t" } { set comment [ad_html_to_text $content] } + + set author_id [km_conn original_author_id] + set author_email [km_conn original_author_email] + + db_1row object_info { + select u.email as sender_email, + u.first_names || ' ' || u.last_name as sender_name, + site_node.url(sn.node_id) as package_url + from users u, site_nodes sn + where u.user_id = :user_id + and sn.object_id = :package_id + } + + set replacement_list \ + [list \ + knowledge_object $object_name \ + knowledge_object_link [ad_url]${package_url}object-view?object_id=$object_id \ + knowledge_object_type $object_type \ + feedback_type $feedback_category \ + recipient_email $author_email \ + sender_email $sender_email \ + sender_name $sender_name \ + comment $content] + + # This uses sn_community_instances_all. Should it be using + # sn_community_mounts_all instead? + set package_id [ad_conn package_id] + set community_id [db_string get_community_id { + select community_id + from sn_community_instances_all + where package_id = :package_id }] + + et_queue_email [et_process -community_id $community_id "km_object_feedback_delete" $replacement_list] +} + +ad_returnredirect $return_url Index: openacs-4/contrib/obsolete-packages/library/www/comment-delete.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/comment-delete.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/comment-delete.adp 2 Jul 2003 12:19:42 -0000 1.1 @@ -0,0 +1,33 @@ +
+@overview_with_href_and_mailto;noquote@ + ++ +
@headline@
+ + + +
@object_name@Index: openacs-4/contrib/obsolete-packages/library/www/comment-delete.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/comment-delete.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/comment-delete.tcl 2 Jul 2003 12:19:42 -0000 1.1 @@ -0,0 +1,71 @@ +ad_page_contract { + /packages/library/www/comment-delete.tcl + + Allow the admin to delete feedback + + @author Timo Hentschel (timo@arsdigita.com) + + @cvs-id $Id: comment-delete.tcl,v 1.1 2003/07/02 12:19:42 peterm Exp $ +} { + comment_id:notnull,integer + {category_id ""} + {path_id:integer ""} +} -properties { + title:onevalue + object_name:onevalue + overview_with_href_and_mailto:onevalue + content:onevalue + author:onevalue + admin_p:onevalue + rating:onevalue + scale:onevalue + feedback_category:onevalue + form_vars:onevalue + form_vars_cancel:onevalue + dc_export:onevalue + subsite_url:onevalue + subsite_name:onevalue +} + +set user_id [ad_maybe_redirect_for_registration] +set package_id [ad_conn package_id] + +set object_id [km_check_comment_id $user_id $comment_id] +if !$object_id { return } + +set object_name [km_conn object_name] + +db_1row get_comment_data { + select sc.content, sc.html_p, rating, scale, + c.long_name as feedback_category, sc.display_p as public_p, + u.first_names || ' ' || u.last_name as author + from sn_comments sc, categories c, users u + where comment_id=:comment_id + and sc.category_id = c.category_id(+) + and u.user_id = sc.user_id } + +set admin_p [km_conn admin_p] + +if {!$admin_p} { + ad_return_complaint 1 "Only admins can delete feedback!" + return +} + +set title "Delete feedback on \"$object_name\"" +set_the_usual_klib_context_bar $object_id $category_id +append_context_bar_data "Delete feedback" +set overview_with_href_and_mailto [util_make_href_and_mailto_links [km_conn overview]] +set form_vars [export_form_vars comment_id category_id path_id] +set form_vars_cancel [export_form_vars object_id category_id path_id] + +array set node [site_node_closest_ancestor_site_node "acs-subsite"] +set subsite_url $node(url) +set subsite_name $node(instance_name) + +if { [string eq $html_p "f"] } { + set content [ad_quotehtml $content] +} + +set dc_export [doubleclick::signature_html] + +ad_return_template Index: openacs-4/contrib/obsolete-packages/library/www/comment-edit-2.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/comment-edit-2.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/comment-edit-2.tcl 2 Jul 2003 12:19:42 -0000 1.1 @@ -0,0 +1,122 @@ +ad_page_contract { + /packages/library/www/comment-edit-2.tcl + + Commits the feedback changes to the db. + + @author Timo Hentschel (timo@arsdigita.com) + + @cvs-id $Id: comment-edit-2.tcl,v 1.1 2003/07/02 12:19:42 peterm Exp $ +} { + comment_id:notnull,integer + comment:notnull + {html_p:oneof(t|f) "f"} + {feedback_category_id:integer ""} + {public_p:optional "f"} + {category_id ""} + {path_id:integer ""} +} +csrf::authenticate + +set user_id [ad_maybe_redirect_for_registration] +set package_id [ad_conn package_id] +set object_id [km_check_comment_id $user_id $comment_id] +if !$object_id { return } + +set admin_p [km_conn admin_p] +set object_name [sn_striphtml [km_conn object_name]] +set object_type [km_static object_type_pretty_name [km_conn object_type_id]] + +set category_forward_email "" +set scale 0 + +db_0or1row get_rating_scale { + select scale, email as category_forward_email + from sn_comments_category_settings + where object_id = :package_id + and category_id = :feedback_category_id +} + +db_1row get_message_data { + select u.email as feedback_author_email, u.user_id as feedback_author_id + from sn_comments sc, users u + where sc.comment_id = :comment_id + and u.user_id = sc.user_id } + +if {!$admin_p && (($user_id != $feedback_author_id) || [km_conn archived_p])} { + ad_return_forbidden "Only the feedback author or admins can edit feedback!" + return +} + +set return_url "object-view?[export_url_vars object_id category_id path_id]" + +db_transaction { + + km_general_comment_update -html_p $html_p -public_p $public_p -feedback_category_id $feedback_category_id $feedback_author_id $object_id $comment_id $comment + + if { $html_p == "t" } { set comment [ad_html_to_text $comment] } + + set author_id [km_conn original_author_id] + set author_email [km_conn original_author_email] + + db_1row object_info { + select u.email as sender_email, + u.first_names || ' ' || u.last_name as sender_name, + site_node.url(sn.node_id) as package_url + from users u, site_nodes sn + where u.user_id = :user_id + and sn.object_id = :package_id + and rownum = 1 + } + + if {![empty_string_p $feedback_category_id]} { + set feedback_category [db_string comment_edit_2_20 { + select long_name from categories + where category_id = :feedback_category_id + } -default ""] + } else { + set feedback_category "" + } + + # This uses sn_community_instances_all. Should it be using + # sn_community_mounts_all instead? + set community_id [db_string get_community_id { + select community_id + from sn_community_instances_all + where package_id = :package_id + }] + + if { $user_id != $author_id } { + set replacement_list \ + [list \ + knowledge_object $object_name \ + knowledge_object_link [ad_url]${package_url}object-view?object_id=$object_id \ + knowledge_object_type $object_type \ + feedback_type $feedback_category \ + recipient_email $author_email \ + sender_email $sender_email \ + sender_name $sender_name \ + comment $comment] + + et_queue_email [et_process -community_id $community_id "km_object_feedback_edit" $replacement_list] + } + + if { $admin_p && $feedback_author_id != $user_id } { + # we have to sent the feedback author an email that an admin changed + # his feedback + + set replacement_list \ + [list \ + knowledge_object $object_name \ + knowledge_object_link [ad_url]${package_url}object-view?object_id=$object_id \ + knowledge_object_type $object_type \ + feedback_type $feedback_category \ + recipient_email $feedback_author_email \ + sender_email $sender_email \ + sender_name $sender_name \ + comment $comment] + + et_queue_email [et_process -community_id $community_id "km_object_feedback_edit_admin" $replacement_list] + } +} + +ad_returnredirect $return_url Index: openacs-4/contrib/obsolete-packages/library/www/comment-edit.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/comment-edit.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/comment-edit.adp 2 Jul 2003 12:19:42 -0000 1.1 @@ -0,0 +1,61 @@ +
+@overview_with_href_and_mailto;noquote@ + +Feedback:
+ ++ Feedback author: @author@+ +
+Feedback type: @feedback_category@ +Rating: @rating@ out of @scale@ points +Comment:
@content;noquote@ +Do you really want to delete this feedback? +
Please be aware that the shares awarded for this feedback will NOT +be taken away by this action - you have to do these things in the Incentive system. +
+ +
+ + + +
@object_name@Index: openacs-4/contrib/obsolete-packages/library/www/comment-edit.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/comment-edit.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/comment-edit.tcl 2 Jul 2003 12:19:42 -0000 1.1 @@ -0,0 +1,120 @@ +ad_page_contract { + /packages/library/www/comment-edit.tcl + + Allow the user to edit one of his general comments. + + @author Carsten Clasohm (carsten@arsdigita.com) + @author Timo Hentschel (timo@arsdigita.com) + + @cvs-id $Id: comment-edit.tcl,v 1.1 2003/07/02 12:19:42 peterm Exp $ +} { + comment_id:notnull,integer + {category_id ""} + {path_id:integer ""} +} -properties { + title:onevalue + object_name:onevalue + object_id:onevalue + objec_type:onevalue + overview_with_href_and_mailto:onevalue + content:onevalue + rating:onevalue + scale:onevalue + admin_p:onevalue + feedback_category_id:onevalue + feedback_category:onevalue + public_p:onevalue + categories:multirow + form_vars:onevalue + user_id:onevalue + author_id:onevalue + subsite_url:onevalue + subsite_name:onevalue + header_stuff:onevalue +} + +set user_id [ad_maybe_redirect_for_registration] +set package_id [ad_conn package_id] + +array set node [site_node_closest_ancestor_site_node "acs-subsite"] +set community_id $node(package_id) + +set object_id [km_check_comment_id $user_id $comment_id] +if { !$object_id } { return } + +set object_name [km_conn object_name] +set object_type [km_static object_type_pretty_name [km_conn object_type_id]] + +set author_id [km_conn original_author_id] +set author_name [km_conn original_author_name] + +set admin_p [km_conn admin_p] + +array set node [site_node_closest_ancestor_site_node "acs-subsite"] +set subsite_url $node(url) +set subsite_name $node(instance_name) +set header_stuff "" + +if {$admin_p} { + set title "Edit feedback for \"$object_name\"" + set header "Edit feedback" +} else { + set title "Edit comment on \"$object_name\"" + set header "Edit comment" +} + +set_the_usual_klib_context_bar $object_id $category_id +append_context_bar_data $header +set overview_with_href_and_mailto [util_make_href_and_mailto_links [km_conn overview]] + +template::multirow create categories category_id name deprecated_p level + +db_1row get_comment_data { + select sc.content, sc.html_p, rating, scale, c.category_id as feedback_category_id, + c.long_name as feedback_category, sc.display_p as public_p, sc.user_id as feedback_author_id + from sn_comments sc, categories c + where comment_id=:comment_id + and sc.category_id = c.category_id(+) } + +if {!$admin_p && (($user_id != $feedback_author_id) || [km_conn archived_p])} { + ad_return_forbidden "Only the feedback author or admins can edit feedback!" + return +} + +if { [string eq $html_p "f"] } { + set content [ad_quotehtml $content] +} + +set feedback_object_id 0 +set form_vars [export_form_vars comment_id category_id path_id feedback_category_id] + +if { $admin_p } { + #assuming that only one tree(subtree) is assigned to this object + + set feedback_category_tree_assigned_p [db_0or1row feedback_category_tree { + select gt.tree_name, octr.subtree_root_node_id, gt.root_node_id as original_root_node_id + from generic_trees gt, + acs_rels ar, + object_category_tree_rels octr + where ar.object_id_one = :package_id + and ar.object_id_two = gt.tree_id + and ar.rel_id = octr.rel_id + and rel_type = 'object_category_tree_rel'}] + + if {$feedback_category_tree_assigned_p} { + db_foreach get_one_tree_edit { + select /*+INDEX(sw_category_dim sw_category_dim_long_name) */ category.long_name(object_id) as name, + category.sort_key(object_id) as sort_key, + object_id as fb_category_id, deprecated_p, level + from sw_category_dim + start with node_id = :subtree_root_node_id + connect by prior node_id = parent_node_id + } { + template::multirow append categories $fb_category_id $name $deprecated_p $level + } + + set form_vars [export_form_vars comment_id category_id path_id] + } +} + +ad_return_template Index: openacs-4/contrib/obsolete-packages/library/www/content-link-add.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/content-link-add.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/content-link-add.tcl 2 Jul 2003 12:19:42 -0000 1.1 @@ -0,0 +1,86 @@ +ad_page_contract { + $Id: content-link-add.tcl,v 1.1 2003/07/02 12:19:42 peterm Exp $ +} { + target:integer,notnull + pass:integer,notnull + link_comment +} +csrf::authenticate + +if ![path_valid_p $pass] { + ad_return_error "Invalid Path" \ + "The current path ID is invalid. Perhaps you used your browser's Back button + and tried to add another user?" + return +} +set object_id $target +set user_id [ad_maybe_redirect_for_registration] + +# Determine to which object we are going to add the user reference, +# and if the current user is allowed to do this. + +set values [get_path_values -action_only_p 0 $pass] +set object_id_a [value_from_tuples $values object_id] +set question_id [value_from_tuples $values question_id] + +if ![km_check_object_id -check_edit_p 1 $object_id_a] { return } + +ad_permission_p $target read + +# Hardcoding the link type_id here. +set link_type bi_directional + +set exists_p [db_string content_link_add_10 " + select decode(count(*),0,0,1) from sn_links + where object_id_a=:object_id_a and object_id_b=:object_id"] + +if {!$exists_p} { + db_transaction { + + set new_link_id [db_string content_link_add_15 "select sn_links_seq.nextval from dual"] + + db_dml content_link_add_20 " + insert into sn_links (link_id, link_type, object_id_a, object_id_b, + creation_user, creation_date, link_comment) + select :new_link_id, 'bi_directional', :object_id_a, :object_id, + :user_id, sysdate, :link_comment + from dual + where not exists (select 1 from sn_links + where object_id_a=:object_id_a and object_id_b=:object_id)" + + db_dml content_link_add_25 " + insert into sn_question_link_map (link_id, question_id) + values (:new_link_id, :question_id)" + + db_dml content_link_add_30 " + update acs_objects + set last_modified = sysdate, modifying_user = :user_id + where object_id = :object_id_a" + + db_dml content_link_add_35 " + update sn_objects + set last_modified = sysdate, last_modifying_user_id = :user_id + [km_link_description_update $object_id_a $question_id] + where object_id = :object_id_a" + + db_dml content_link_add_40 " + update acs_objects_description + set state = state + where object_id = :object_id_a" + + set one_line_desc [db_string content_link_add_50 "select shortname + from acs_objects_description + where object_id=:object_id"] + + set audit_comment "Added link to \"$one_line_desc\"" + db_dml content_link_add_60 { + insert into sn_audit_table + (object_id, question_id, last_modified, last_modifying_user_id, content) + values (:object_id_a, :question_id, sysdate, :user_id, :audit_comment)} + +} +} + +# All done, back to the path's origin. + +ad_returnredirect [get_path_return_url $pass] Index: openacs-4/contrib/obsolete-packages/library/www/content-link-delete-2.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/content-link-delete-2.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/content-link-delete-2.tcl 2 Jul 2003 12:19:42 -0000 1.1 @@ -0,0 +1,58 @@ +# /www/library/content-link-delete-2.tcl +# +# Delete an object-content link. +# +# $Id: content-link-delete-2.tcl,v 1.1 2003/07/02 12:19:42 peterm Exp $ + +ad_page_variables { + link_id + return_url +} +csrf::authenticate + +set user_id [ad_maybe_redirect_for_registration] + +# We are dealing with object <-> content links here. +# The following query relies on the object being +# referenced by the object_id_a column. + +if {![db_0or1row content_link_delete_2_10 " + select obj1.object_id, obj2.shortname as one_line_description, map.question_id + from sn_links l, sn_objects obj1, acs_objects_description obj2, sn_question_link_map map + where l.link_id=:link_id + and obj1.object_id = l.object_id_a + and obj2.object_id = l.object_id_b + and l.link_id = map.link_id"]} { + # The link already has been deleted. + ad_returnredirect $return_url + return +} + +# Check if the user is authorized to delete this link. + +if ![ad_permission_p $object_id write] { + ad_return_error "Not authorized" "You are not authorized to delete this link." + return +} + +# All checks passed - let's delete the row. + +set audit_comment "Deleted link to '$one_line_description'" + +db_transaction { + db_dml content_link_delete_2_20 "delete from sn_links where link_id=:link_id" + db_dml content_link_delete_2_21 "delete from sn_question_link_map where link_id=:link_id" + + db_dml content_link_delete_2_40 { + insert into sn_audit_table + (object_id, question_id, last_modified, last_modifying_user_id, content) + values (:object_id, :question_id, sysdate, :user_id, :audit_comment)} + + db_dml content_link_delete_2_50 " + update sn_objects + set last_modified = sysdate, last_modifying_user_id = :user_id + [km_link_description_update $object_id $question_id] + where object_id = :object_id" +} + +ad_returnredirect $return_url Index: openacs-4/contrib/obsolete-packages/library/www/content-link-delete.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/content-link-delete.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/content-link-delete.adp 2 Jul 2003 12:19:42 -0000 1.1 @@ -0,0 +1,22 @@ +
+@overview_with_href_and_mailto;noquote@ + +Edit
+ +your the comment on the @object_type@ "@object_name@".
+ +
| + + | ++ + | +
| + + | ++ + | +
| Graphic | + +Browse Knowledge Objects | + +Create Knowledge Objects | +
|---|---|---|
|
+
+ |
+
+
+ @object_types.pretty_plural@
+ Archived @object_types.pretty_plural@ + |
+
+
+ Copy a @object_types.pretty_name@ + |
+
Object Approval Tasks
+| To do | On what | Submitted | Started |
|---|---|---|---|
| @task_list.task_name@ | +@task_list.object_type_pretty@ "@task_list.object_name@" | +@task_list.enabled_date@ by @task_list.submitter_name@ | +@task_list.started_date@ |
" + } + template::multirow append tags $name $item_value $checked_string $item $break + incr counter +} Index: openacs-4/contrib/obsolete-packages/library/www/km-content-link-table.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/km-content-link-table.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/km-content-link-table.adp 2 Jul 2003 12:19:42 -0000 1.1 @@ -0,0 +1,27 @@ +
| No | +Headline | + +Action | +|
|---|---|---|---|
@content_links.i@ |
+ @content_links.pretty_object;noquote@ |
+ @content_links.link_comment;noquote@ |
+
+ + Edit linking reason | + Delete Link | +
+
|
+
+
|
+
|
+ @fields.pretty_name;noquote@ |
@fields.entry_explanation;noquote@
+@fields.entry_explanation;noquote@
+
Show
+ category descriptions
+
Show
+ category descriptions
+
-
+
| @linked_objects_list.pretty_type_plural@ + + |
-
+
Question: @linked_objects_list.question;noquote@ +
@linked_objects_list.overview@ +
+
Add a reference to + +
+@user_links.i@ Describe shortly the connection between "@original_object_name@"
+and the @target_object_type@ you are linking it to. Access has been granted to @grantee_name@.
+
+You may return to where
+you were, or also grant access to the linked objects below. To do
+so, select any number of objects and press Proceed.
+
+
+
+
+
+
Index: openacs-4/contrib/obsolete-packages/library/www/km-user-link-table.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/km-user-link-table.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/km-user-link-table.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,35 @@
+# Displays the list of user-objects links when existing_links is supplied as a
+# list of lists in the order: user_id full_name
+
+if {![info exists edit_p]} {
+ set edit_p 0
+}
+
+if {![info exists object_id]} {
+ set object_id 0
+}
+
+if {![info exists category_id]} {
+ set category_id ""
+}
+
+if {![info exists question_id]} {
+ set question_id 0
+}
+
+# existing_links
+
+set return_url "[ns_conn url]?[ns_conn query]"
+set community_name [km_get_community_name]
+
+template::multirow create user_links i user_id user_name url_vars link_id
+set i 1
+foreach link $existing_links {
+ set user_id [fst $link]
+ set user_name [snd $link]
+ set link_id [lindex $link 4]
+ set url_vars [export_url_vars link_id object_id category_id question_id]
+
+ template::multirow append user_links $i $user_id $user_name $url_vars $link_id
+ incr i
+}
Index: openacs-4/contrib/obsolete-packages/library/www/km-yes-no.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/km-yes-no.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/km-yes-no.adp 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,3 @@
+Yes
+No
+
Index: openacs-4/contrib/obsolete-packages/library/www/km-yes-no.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/km-yes-no.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/km-yes-no.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,12 @@
+if {![info exists default]} {
+ set default 0
+}
+
+if {$default} {
+ set checked_yes "CHECKED"
+ set checked_no ""
+} else {
+ set checked_no "CHECKED"
+ set checked_yes ""
+}
+
Index: openacs-4/contrib/obsolete-packages/library/www/link-delete-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/link-delete-2.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/link-delete-2.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,61 @@
+# /www/library/link-delete-2.tcl
+#
+# Delete an object-object link.
+#
+# $Id: link-delete-2.tcl,v 1.1 2003/07/02 12:19:43 peterm Exp $
+
+ad_page_variables {
+ link_id
+ return_url
+}
+csrf::authenticate
+
+set user_id [ad_maybe_redirect_for_registration]
+
+# We are dealing with object <-> object links here. The following
+# query relies on the originating object being referenced by the
+# object_id_a column.
+
+if {![db_0or1row link_delete_2_10 {
+ select obj1.object_id as object_id_a, obj2.object_id as object_id_b, map.question_id
+ from sn_links l, sn_objects obj1, sn_objects obj2, sn_question_link_map map
+ where l.link_id=:link_id
+ and map.link_id = l.link_id
+ and obj1.object_id = object_id_a
+ and obj2.object_id = object_id_b}]} {
+ # The link already has been deleted.
+ ad_returnredirect $return_url
+ return
+}
+
+# Check if the user is authorized to delete this link.
+
+if ![km_check_object_id -check_edit_p 1 $object_id_a] { return }
+
+db_transaction {
+
+db_1row link_delete_2_20 "
+select object_id as object_id_b, one_line_description as target_name, pretty_name as target_type
+from sn_objects obj, sn_object_types ot
+where object_id=:object_id_b
+and obj.object_type_id = ot.object_type_id"
+
+# All checks passed - let's delete the row.
+
+db_dml link_delete_2_30 "delete from sn_links where link_id=:link_id"
+
+db_dml link_delete_2_50 "
+ insert into sn_audit_table
+ (object_id, question_id, last_modified, last_modifying_user_id, content)
+ values ($object_id_a, $question_id, sysdate, $user_id,
+ 'Deleted link to $target_type \"[DoubleApos $target_name]\"')"
+
+db_dml link_delete_2_6 "
+ update sn_objects
+ set last_modified = sysdate, last_modifying_user_id = $user_id
+ [km_link_description_update $object_id_a $question_id]
+ where object_id = $object_id_a"
+
+}
+
+ad_returnredirect $return_url
Index: openacs-4/contrib/obsolete-packages/library/www/link-delete.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/link-delete.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/link-delete.adp 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,22 @@
+No. @community_name@ Community Member Action No. @community_name@ Community Member
+
+
+
+
+
+
+
Index: openacs-4/contrib/obsolete-packages/library/www/link-delete.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/link-delete.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/link-delete.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,31 @@
+# /www/library/link-delete.tcl
+#
+# Ask for confirmation before deleting an object-object link.
+#
+# $Id: link-delete.tcl,v 1.1 2003/07/02 12:19:43 peterm Exp $
+
+ad_page_variables {
+ object_id
+ link_id
+ {category_id ""}
+ {return_url ""}
+}
+
+if ![km_check_object_id -check_edit_p 1 $object_id] { return }
+
+if [empty_string_p $return_url] {
+ set return_url "object-link?[export_url_vars object_id category_id question_id]"
+}
+
+set question_id [db_string link_delete_10 "
+ select question_id from sn_question_link_map where link_id=:link_id"]
+
+set object_name [km_conn object_name]
+
+set title "Delete Link"
+set_the_usual_klib_context_bar $object_id $category_id
+append_context_bar_data "Delete Link"
+
+set form_vars_delete [export_form_vars link_id return_url]
+set form_vars_cancel [export_form_vars object_id category_id question_id]
+ad_return_template
Index: openacs-4/contrib/obsolete-packages/library/www/link-reason-add.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/link-reason-add.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/link-reason-add.adp 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,23 @@
+
+
+
+
+
+
+
+
+
+
+
+
Index: openacs-4/contrib/obsolete-packages/library/www/link-reason-add.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/link-reason-add.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/link-reason-add.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,40 @@
+ad_page_contract {
+ link-reason-add.tcl
+
+ After the user has selected or created an object for linking,
+ ask him for the link comment.
+
+ $Id: link-reason-add.tcl,v 1.1 2003/07/02 12:19:43 peterm Exp $
+} {
+ object_id:notnull,integer
+ path_id:notnull
+}
+
+set user_id [ad_maybe_redirect_for_registration]
+
+if ![path_valid_p $path_id] {
+ ad_return_error "Invalid Path" \
+ "The current path ID is invalid. Perhaps you used your browser's Back button
+ and tried to add another link?"
+ return
+}
+
+set path_values [get_path_values -action_only_p 0 $path_id]
+set original_object_id [value_from_tuples $path_values object_id]
+set category_id [value_from_tuples $path_values category_id]
+
+if ![km_check_object_id -check_edit_p 1 $original_object_id] { return }
+
+set original_object_name [km_conn object_name]
+set target_object_type [db_string get_object_type {
+ select ot.pretty_name
+ from sn_object_types ot, sn_objects o
+ where o.object_id = :object_id
+ and ot.object_type_id = o.object_type_id
+}]
+
+set title "Reason for linking to \"$original_object_name\""
+set_the_usual_klib_context_bar $object_id $category_id
+append_context_bar_data "Reason for linking"
+set form_vars [export_form_vars object_id path_id link_id link_comment_id]
+ad_return_template
Index: openacs-4/contrib/obsolete-packages/library/www/link-reason-edit-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/link-reason-edit-2.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/link-reason-edit-2.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,52 @@
+# /www/library/link-reason-edit-2.tcl
+#
+# Save the changed linking comment.
+#
+# $Id: link-reason-edit-2.tcl,v 1.1 2003/07/02 12:19:43 peterm Exp $
+
+ad_page_variables {
+ object_id
+ link_id
+ question_id
+ link_comment
+ html_p
+ return_url
+}
+csrf::authenticate
+
+set html_p [ad_decode $html_p 1 t f]
+set user_id [ad_maybe_redirect_for_registration]
+
+# Check if the user is authorized to change this comment.
+if ![km_check_object_id -check_edit_p 1 $object_id] { return }
+
+set ip_address [ns_conn peeraddr]
+
+db_transaction {
+
+db_1row km_link_objects_20 "
+ select one_line_description as target_name, pretty_name as target_type
+ from sn_objects obj, sn_object_types ot
+ where object_id=:object_id
+ and obj.object_type_id = ot.object_type_id"
+
+set content "Changed comment for link to $target_type \"[DoubleApos $target_name]\": $QQlink_comment"
+
+db_dml link_reason_edit_10 {update sn_links set link_comment = :link_comment, html_p = :html_p where link_id =:link_id}
+
+set ip_address [ns_conn peeraddr]
+db_exec_plsql link_reason_edit_20 {
+ begin
+ object.audit_object (
+ v_object_id => :object_id,
+ v_question_id => :question_id,
+ v_last_modifying_user_id => :user_id,
+ v_modifying_ip => :ip_address,
+ v_content => :content
+ );
+ end;
+}
+
+}
+
+ad_returnredirect $return_url
Index: openacs-4/contrib/obsolete-packages/library/www/link-reason-edit.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/link-reason-edit.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/link-reason-edit.adp 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,20 @@
+
+
+
Index: openacs-4/contrib/obsolete-packages/library/www/link-reason-edit.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/link-reason-edit.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/link-reason-edit.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,29 @@
+ad_page_contract {
+ link-reason-edit.tcl
+ Allow the user the change the linking reason.
+} {
+ object_id
+ link_id
+ {category_id ""}
+ {return_url ""}
+}
+
+if ![km_check_object_id -check_edit_p 1 $object_id] { return }
+
+if [empty_string_p $return_url] {
+ set return_url "object-link?[export_url_vars object_id category_id question_id]"
+}
+
+db_1row link_reason_edit_10 "
+ select question_id, link_comment, html_p
+ from sn_links l, sn_question_link_map map
+ where l.link_id=:link_id and map.link_id=l.link_id"
+
+set object_name [km_conn object_name]
+
+set title "Edit Reason for Linking"
+
+set_the_usual_klib_context_bar $object_id $category_id
+append_context_bar_data $title
+set form_vars [export_form_vars link_id return_url object_id question_id]
+ad_return_template
Index: openacs-4/contrib/obsolete-packages/library/www/master.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/master.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/master.adp 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,16 @@
+Describe shortly the connection between the two linked objects. Users allowed to view
+
+
+
+
+Users allowed to edit
+
+
+
+
+
+
+Grant read and write access to a user
+
+
+
+Groups allowed to view
+
+
+
+
+Groups allowed to edit
+
+
+
+
+
+
+Grant read and write access to a group
+
+@history.name@ on @history.modified_date@ @history.modified_time@ by
+
+
+
+
+Status change: @history.content;noquote@ Added content to @history.question_name@: @history.content;noquote@ Modified content for @history.question_name@: @history.content;noquote@
At least one mandatory question has not been answered. Please
+ edit
+ the object and add any missing data."
+ return
+}
+
+# have to compose workflow comment if nephew_list supplied
+if ![empty_string_p $nephew_list] {
+ set msg_list [list]
+ set last_nephew_type_id ""
+
+ db_foreach get_nephew_data "
+ select object_id as nephew_id, one_line_description as nephew_name,
+ object_type_id as nephew_type_id
+ from sn_objects
+ where object_id in ([join $nephew_list ,])
+ order by object_type_id, one_line_description
+ " {
+ if [empty_string_p $nephew_name] {
+ set nephew_name "Unnamed [km_static object_type_pretty_name $nephew_type_id]"
+ }
+ if {$last_nephew_type_id != $nephew_type_id} {
+ lappend msg_list "[km_static object_type_pretty_plural $nephew_type_id]: $nephew_name"
+ set last_nephew_type_id $nephew_type_id
+ } else {
+ lappend msg_list $nephew_name
+ }
+ }
+ set msg "The following linked objects should be made public as well: [join $msg_list ,]"
+}
+
+db_transaction {
+ # mark objects as in_review_p
+ db_dml mark_objects_in_review_p "
+ update sn_objects
+ set in_review_p = 't'
+ where object_id in ([join $descendents ,])
+ "
+
+ # Actually submit objects for publication.
+ set case_id [db_exec_plsql object_queue_for_review {
+ begin
+ :1 := library_workflow.new_workflow_case (
+ p_object_id => :object_id,
+ p_creation_user => :user_id,
+ p_creation_ip => :creation_ip,
+ p_publisher_id => :publisher_id
+ );
+ end;
+ }]
+
+ # add workflow comment for selected nephews
+ if ![empty_string_p $nephew_list] {
+ db_exec_plsql add_workflow_comment {
+ begin
+ :1 := journal_entry.new(
+ object_id => :case_id,
+ action => 'case start',
+ action_pretty => 'Case started',
+ creation_user => :user_id,
+ creation_ip => :creation_ip,
+ msg => :msg
+ );
+ end;
+ }
+ }
+}
+
+ad_returnredirect $return_url
+
+
Index: openacs-4/contrib/obsolete-packages/library/www/object-propose-public.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/object-propose-public.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/object-propose-public.adp 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,47 @@
+ At least one mandatory question has not been answered. Please
+ edit the
+ object and add any missing data. Sorry. @title@. At least one mandatory question has not been answered for each linked
+ knowledge object of the following questions:
+ At least one mandatory question has not been answered. Please
+ edit
+ the object and add any missing data."
+ return
+}
+
+db_transaction {
+
+ # Check if a user already got shares for this entry (by making
+ # it public). If not, give him the shares. This is ignoring
+ # the issue of different banks, but that's OK because we just
+ # want to know if he was rewarded for publishing the object,
+ # not where and how the reward took place.
+ set awardedp [db_string object_awarded_shares {
+ select count(*) from ir_share_transactions
+ where cc_name = 'kl_object_publish' and object_id = :object_id
+ }]
+
+ if {!$awardedp && ![km_is_nephew_p $object_id]} {
+ foreach bank_id [incentives::bank_list -user_id $original_author_id $package_id] {
+ set amount [incentives::charge_value -key $object_type_id \
+ kl_object_publish $bank_id]
+ incentives::award_shares -user_id $original_author_id \
+ kl_object_publish $amount $bank_id $object_id
+ }
+ }
+
+ # Actually publish the object.
+ km_object_publish $descendents
+
+ # Generate alerts.
+ set published_objects_list [db_list_of_lists get_published_objects "
+ select object_id, object_type_id
+ from sn_objects
+ where public_p = 't'
+ and object_id in ([join $descendents ,])
+ "]
+
+ foreach published_object $published_objects_list {
+ util_unlist $published_object published_object_id published_object_type_id
+
+ alerts::generate_alert -package_id $package_id -content_type_id $published_object_type_id -action insert -link_only $published_object_id
+ }
+
+ ## but what if the task is at a clarify state? can we close it then
+ ## with this code?
+ if ![info exists task_id] {
+ db_0or1row get_workflow_case {
+ select case_id
+ from wf_cases
+ where object_id = :object_id
+ and state = 'active'
+ and rownum = 1
+ order by case_id desc
+ }
+ if [info exists case_id] {
+ db_dml delete_task_assignments {
+ delete from wf_task_assignments
+ where task_id in (select task_id from wf_tasks where case_id = :case_id)
+ }
+ db_dml finish_tasks {
+ update wf_tasks
+ set state = 'finished'
+ where case_id = :case_id
+ }
+ db_dml delete_tokens {
+ delete from wf_tokens
+ where case_id = :case_id
+ }
+ db_1row get_task_id {
+ select wf_task_id_seq.nextval as task_id from dual
+ }
+ db_dml insert_transition_key {
+ insert into wf_tasks
+ (task_id, case_id, workflow_key, transition_key, state, started_date, holding_user)
+ values (:task_id, :case_id, 'library_approval_wf', 'library_review', 'started', sysdate, :user_id)
+ }
+ set msg "Object Published"
+ }
+ }
+
+ if [info exists task_id] {
+ # update publisher_id
+ db_dml update_publisher_id "
+ update sn_objects
+ set publisher_id = :user_id
+ where object_id in ([join $descendents ,])
+ "
+
+ #finish workflow task
+ set journal_id [wf_task_action -user_id $user_id -msg $msg -attributes [list library_object_needs_clarification f] $task_id finish]
+ }
+}
+
+ad_returnredirect $return_url
Index: openacs-4/contrib/obsolete-packages/library/www/object-publish.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/object-publish.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/object-publish.adp 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,66 @@
+
- @shares.bank_name@: @shares.amount@ @shares.currency@ (New balance: @shares.balance@ @shares.currency@) +
- @shares.bank_name@: @shares.amount@ @shares.currency@ +
At least one mandatory question has not been answered. Please + edit the + object and add any missing data.
+Sorry. @title@.
+At least one mandatory question has not been answered for each linked + knowledge object of the following questions: +
+
+ On this page you see all links that exist to or from the @pretty_type@
+"@object_name@". Along with the object itself, the linking direction
+and the question that led to the link are displayed:
+ @workspace_toolbar;noquote@
+
+ @comments.category@
+
+ @comments.content;noquote@
+
+ -- @comments.commenter_name@, @comments.comment_date@
+ @object_access_toolbar;noquote@
Index: openacs-4/contrib/obsolete-packages/library/www/object-view.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/object-view.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/object-view.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,316 @@
+ad_page_contract {
+ object-view.tcl
+
+ Display the completed content of an object.
+
+ @author Timo Hentschel (timo@arsdigita.com)
+ $Id: object-view.tcl,v 1.1 2003/07/02 12:19:43 peterm Exp $
+} {
+ object_id:integer
+ {category_id ""}
+ {path_id:integer ""}
+} -properties {
+ title:onevalue
+ write_feedback_of_object:onevalue
+ object_id:onevalue
+ object_type_id:onevalue
+ pretty_type:onevalue
+ date_created:onevalue
+ public_p:onevalue
+ checkoff_date:onevalue
+ pretty_checkoff_date:onevalue
+ date_last_modified:onevalue
+ author_id:onevalue
+ author_name:onevalue
+ length_linked_objects:onevalue
+ object_list:onevalue
+ read_only_child_p:onevalue
+ object_access_toolbar:onevalue
+ display_object_data:multirow
+ linked_urls_list:onevalue
+ workspace_toolbar:onevalue
+ access_count:onevalue
+ access_count_month:onevalue
+ edit_p:onevalue
+ admin_p:onevalue
+ delete_p:onevalue
+ change_owner_p:onevalue
+ change_publisher_p:onevalue
+ user_id:onevalue
+ reuse_p:onevalue
+ comments:multirow
+ path_id:onevalue
+ category_id:onevalue
+ subsite_url:onevalue
+ subsite_name:onevalue
+ community_id:onevalue
+ public_p:onevalue
+ bookmarked_p:onevalue
+ shopping_cart_p:onevalue
+ child_p:onevalue
+ nephew_p:onevalue
+ application_p:onevalue
+ application_form_vars:onevalue
+ ancestor_object_id:onevalue
+ ancestor_object_type:onevalue
+ ancestor_name:onevalue
+ ancestor_public_p:onevalue
+ ancestor_archived_p:onevalue
+ ancestor_review_p:onevalue
+ publisher_id:onevalue
+ publisher_name:onevalue
+ ot_create_p:onevalue
+ ot_copy_p:onevalue
+ ot_archive_p:onevalue
+ review_p:onevalue
+ task_id:onevalue
+ archived_p:onevalue
+ approval_p:onevalue
+ review_state:onevalue
+ create_p:onevalue
+}
+
+set user_id [ad_conn user_id]
+set package_id [ad_conn package_id]
+set instance_name [ad_conn instance_name]
+
+if ![km_check_object_id $object_id] { return }
+
+set object_type_id [km_conn object_type_id]
+set read_only_child_p 0
+set pretty_type [km_static object_type_pretty_name $object_type_id]
+set pretty_type_plural [km_static object_type_pretty_plural $object_type_id]
+set graphic [km_static object_type_graphic $object_type_id]
+
+array set node [site_node_closest_ancestor_site_node "acs-subsite"]
+set community_id $node(package_id)
+set subsite_url $node(url)
+set subsite_name $node(instance_name)
+set public_p [km_conn public_p]
+set review_p [km_conn in_review_p]
+set review_state [km_conn review_state]
+set original_author_id [km_conn original_author_id]
+set object_name [km_conn object_name]
+set stripped_name [sn_striphtml $object_name]
+set approval_p [km_static approval_p $package_id]
+set ancestor_object_id 0
+set publisher_id [km_conn publisher_id]
+if ![empty_string_p $publisher_id] {
+ set publisher_name [db_string get_publisher_name {select first_names || ' ' || last_name from users where user_id = :publisher_id}]
+} else {
+ set publisher_name ""
+}
+
+# Determine which permissions the viewing user has.
+set admin_p [km_conn admin_p]
+set publish_p [km_conn publish_p]
+set edit_p [km_conn write_p]
+set delete_p [km_conn delete_p]
+set create_p [km_conn create_p]
+set archived_p [km_conn archived_p]
+set ot_archive_p [km_static object_type_archive_p $object_type_id]
+set ot_create_p [km_static object_type_create_p $object_type_id]
+set ot_copy_p [km_static object_type_copy_p $object_type_id]
+set publisher_id [km_conn publisher_id]
+set title "$pretty_type: $stripped_name"
+
+if { ($user_id == $original_author_id && !$archived_p) || $admin_p } {
+ set change_owner_p 1
+} else {
+ set change_owner_p 0
+}
+
+if { $admin_p || $publish_p || $publisher_id == $user_id} {
+ set change_publisher_p 1
+} else {
+ set change_publisher_p 0
+}
+
+## get the task_id of the workflow task if object is in review
+if { $review_p } {
+ set task_id [db_string get_workflow_task {
+ select distinct(ut.task_id)
+ from wf_cases c, wf_user_tasks ut
+ where c.object_id = :object_id
+ and c.case_id = ut.case_id
+ and c.state = 'active'
+ and rownum = 1
+ order by ut.task_id desc
+ } -default ""]
+} else {
+ set task_id ""
+}
+
+# Determine how often the object has been viewed in total, and this month.
+if { $user_id } { km_count_object_view $user_id $object_id }
+
+set access_count [km_conn access_total]
+set access_count_month [km_conn access_month]
+
+# This object may have some parents.
+# The proc returns pairs of parent_object_id and the object name
+set ancestors [reverse [km_get_object_ancestors $object_id]]
+
+if ![null_p $ancestors] {
+ set ancestor [fst $ancestors]
+ set ancestor_object_id [fst $ancestor]
+ set ancestor_object_type [km_static object_type_pretty_name [thd $ancestor]]
+ set ancestor_name [snd $ancestor]
+ db_1row get_public_archived_status {
+ select decode(public_p,'t',1,0) as ancestor_public_p,
+ decode(archived_p,'t',1,0) as ancestor_archived_p,
+ decode(in_review_p,'t',1,0) as ancestor_review_p
+ from sn_objects
+ where object_id = :ancestor_object_id
+ }
+
+ if { !$admin_p } {
+ set ancestor_object_type_id [thd $ancestor]
+ if {[llength $ancestors] > 1} {
+ set ancestor_linked_object_id [fst [snd $ancestors]]
+ } else {
+ set ancestor_linked_object_id $object_id
+ }
+ set ancestor_question_state [db_string object_view_10 "
+ select qm.question_state
+ from sn_question_object_type_map qm, sn_links l, sn_question_link_map map
+ where l.object_id_a = :ancestor_object_id
+ and l.object_id_b = :ancestor_linked_object_id
+ and l.link_id = map.link_id
+ and map.question_id = qm.question_id
+ and qm.object_type_id = :ancestor_object_type_id"]
+ if { $ancestor_question_state == "read-only" } {
+ set edit_p 0
+ set read_only_child_p 1
+ }
+ }
+ set child_p 1
+} else {
+ set child_p 0
+}
+
+set nephew_p [km_is_nephew_p $object_id]
+
+if {$child_p && !$nephew_p} {
+ if {$ot_archive_p} {
+ set return_url "object-view?[export_url_vars object_id]"
+ if { $archived_p && $edit_p } {
+ set object_access_toolbar "\[Archived\] Remove from archive"
+ } else {
+ set object_access_toolbar "Put in archive"
+ }
+ } else {
+ set object_access_toolbar ""
+ }
+} else {
+ set object_access_toolbar [km_object_access_toolbar $object_id $category_id]
+}
+
+if {$nephew_p && [string equal [km_get_presentation_type_of_nephew_question $object_id] "application"]} {
+ set application_p 1
+ set resource_req_id [fst [km_get_uncle $object_id]]
+ set return_url "object-view?[ad_conn query]"
+ set application_form_vars [export_form_vars object_id category_id resource_req_id return_url]
+} else {
+ set application_p 0
+ set application_form_vars ""
+}
+
+if { ![empty_string_p $path_id] && [path_valid_p $path_id] } {
+ set path_values [get_path_values -action_only_p 0 $path_id]
+ set last_path_id [get_last_path $path_id]
+ set browse_type [snd $path_values]
+ set browse_category [lindex $path_values 3]
+
+ set browse_type "browse-one-type?[export_url_vars object_type_id]&path_id=$last_path_id&$browse_type"
+ set browse_category "browse-one-category?[export_url_vars object_type_id category_id]&path_id=$last_path_id&$browse_category"
+} else {
+ set browse_type "browse-one-type?[export_url_vars object_type_id]"
+ set browse_category "browse-one-category?[export_url_vars object_type_id category_id]"
+}
+
+# Set up the context bar. This is so complicated because we
+# not only provide a link to browse-one-type.tcl, but also
+# to browse-one-category.tcl (if needed).
+
+## if {$child_p && !$nephew_p} {
+## set workspace_toolbar ""
+##} else {
+ set workspace_toolbar [km_workspace_toolbar $object_id $category_id $child_p]
+##}
+set_the_usual_klib_context_bar $object_id $category_id
+
+if { $public_p } {
+ set write_feedback_of_object [get_feedback_statistics_for_object $object_id feedback_statistics]
+} else {
+ set write_feedback_of_object 0
+ set feedback_statistics ""
+}
+
+# Display questions and answers (omitting unanswered questions).
+set date_created [util_AnsiDatetoPrettyDate [km_conn creation_date]]
+set date_last_modified [util_AnsiDatetoPrettyDate [km_conn last_modified]]
+set checkoff_date [km_conn user_checkoff_date]
+set pretty_checkoff_date [util_AnsiDatetoPrettyDate [km_conn user_checkoff_date]]
+
+set author_name [km_conn original_author_name]
+set author_id [km_conn original_author_id]
+
+# Retrieve all data for this object as a list of lists in this Special Form:
+# question_id, pretty_question, abstract_data_type, value
+set object_data [km_get_object_data -answers_only_p 0 $object_id]
+
+template::multirow create display_object_data object_id question_id abstract_data_type branch_p root_branch_p pretty_question value edit_p
+
+foreach item $object_data {
+ set value [fst $item]
+ set question_id [snd $item]
+ set pretty_question [thd $item]
+ set abstract_data_type [lindex $item 3]
+ set branch_p [lindex $item 4]
+ set root_branch_p [lindex $item 5]
+
+ if {[empty_string_p $branch_p]} {
+ set branch_p 0
+}
+ if { !$branch_p || [km_active_path_p $question_id $object_id $object_type_id] } {
+ template::multirow append display_object_data $object_id $question_id $abstract_data_type $branch_p $root_branch_p $pretty_question $value $edit_p
+ }
+}
+
+set linked_objects [km_get_linked_objects -to_p 1 -reference_links_p 0 -family_members_p 0 $user_id $object_id]
+if {[llength $linked_objects] <= 1} {
+ set linked_objects ""
+}
+
+set reuse_p 0
+if { $public_p && $original_author_id != $user_id } {
+ # Prevent private objects from getting shares.
+ set reuse_p 1
+}
+
+get_feedback_for_object $object_id comments
+
+if {![empty_string_p $category_id] && ![string equal $category_id none]} {
+ query get_category_tree_info tree_info onerow {
+ select gt.tree_name, gt.tree_id, c.short_name
+ from sw_category_dim scd, generic_trees gt, categories c
+ where scd.object_id = :category_id
+ and scd.tree_id = gt.tree_id
+ and c.category_id = :category_id
+ }
+ set search_contexts [list \
+ [list "lcat:$object_type_id,$tree_info(tree_id),$category_id" "$tree_info(short_name)"] \
+ [list "ltype:$object_type_id" "$pretty_type_plural"] \
+ [list "lib:$package_id" "$instance_name"] \
+ [list "sc:$community_id" "$subsite_name"] \
+ [sws_km_site_search_context]]
+} else {
+ set search_contexts [list \
+ [list "ltype:$object_type_id" "$pretty_type_plural"] \
+ [list "lib:$package_id" "$instance_name"] \
+ [list "sc:$community_id" "$subsite_name"] \
+ [sws_km_site_search_context]]
+}
+
+ad_return_template
Index: openacs-4/contrib/obsolete-packages/library/www/object-xml.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/object-xml.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/object-xml.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,29 @@
+ad_page_contract {
+ /www/library/object-indexed.tcl
+
+ Show intemedia index contents for given object instance
+
+ created by akananov@arsdigita.com 18.10.2000
+
+ @cvs-id $Id:
+} {
+ object_id:notnull,integer
+ {msie_p:boolean 0}
+}
+
+if ![km_check_object_id $object_id] { return }
+if {![km_conn admin_p]} { return }
+
+set sql "
+ select km_utilities.km_xml(object_id) xml_doc from sn_objects
+ where object_id = :object_id"
+
+db_1row object_xml_10 $sql
+
+if {[msie_p]} {
+ set mime application/xml
+} else {
+ set mime text/plain
+}
+
+ns_return 200 $mime $xml_doc
Index: openacs-4/contrib/obsolete-packages/library/www/one-question-edit-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/one-question-edit-2.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/one-question-edit-2.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,278 @@
+ad_page_contract {
+ /www/library/one-question-edit-2.tcl
+
+ First save the data from one-question-edit.tcl, then redirect the user
+ to his destination.
+
+ @cvs-id $Id: one-question-edit-2.tcl,v 1.1 2003/07/02 12:19:43 peterm Exp $
+} {
+ question_id:integer
+}
+csrf::authenticate
+
+set key_values {}
+set_the_usual_form_variables
+set button_name ""
+set new_question ""
+set branch_id ""
+set action ""
+
+# We need some information about this question
+set pretty_name [km_static question_pretty_name $question_id]
+set abstract_data_type [km_static question_abstract_data_type $question_id]
+
+# expecting: object_id path_id
+# In the form: the submit button name, the question's column_name
+# and its value to be stored in the database
+
+set form_size [ns_set size $Vform]
+
+# Go through the form and pick out the data we need for the path from
+# the data that needs to go to Oracle.
+set counter 0
+
+while { $counter < $form_size } {
+
+ set key [ns_set key $Vform $counter]
+ set value [ns_set value $Vform $counter]
+ incr counter
+
+ # Isolate the general name of this form field.
+ # A submit button has the form general_name.question_id
+
+ regexp {(.*)\.} $key match button_name
+
+ # See if this is the form's submit button.
+ if { [lsearch [km_get_button_names] $button_name] >= 0 } {
+ regexp {\.(.*)} $key match button_target
+
+ # This IS the form's submit button which sets the path action.
+ # We want to get the question_id out of it as well.
+
+ set action $button_name
+
+ # The second half of the submit button name is the question_id
+ # for the next/previous question to be edited
+ if { $button_name == "next_question" || $button_name == "previous_question" } {
+ set new_question_id $button_target
+ }
+
+ } else {
+
+ switch $key {
+ "path_id" { set path_id $value }
+ "object_id" { set object_id $value }
+ "object_type_id" { set object_type_id $value }
+ "parent_object_id" { set parent_object_id $value }
+ "uncle_object_id" { set uncle_object_id $value }
+ "question_id" { set question_id $value }
+ "category_id" { set category_id $value }
+ "default" { lappend key_values [list $key $value] }
+ }
+ }
+}
+
+if {![km_check_object_id -check_edit_p 1 $object_id]} {
+ return
+}
+
+set user_id [ad_maybe_redirect_for_registration]
+set archived_p [km_conn archived_p]
+set admin_p [km_conn admin_p]
+set all_types_p 0
+if {$admin_p && $archived_p} {
+ set all_types_p 1
+}
+
+set question [km_get_question -all_types_p $all_types_p $question_id $object_type_id]
+set question_state [lindex $question 3]
+
+if ![info exists path_id] { set path_id "" }
+
+if {[lsearch [list category other_category option] $abstract_data_type] != -1} {
+ set valid_keys [km_filter_valid_keys $key_values]
+ if {![null_p $valid_keys] && [empty_string_p [snd [fst $valid_keys]]]} {
+ set key_values [list]
+ }
+}
+
+if { $action == "delete" } {
+ set results [km_delete_object_data $object_id $button_target]
+}
+
+if { $action == "delete" || ($question_state == "read-only" && !$admin_p) } {
+ # If the user cannot edit or has deleted the content,
+ # then there won't be bad input, and nothing should be saved.
+ set results ""
+} elseif {![null_p [km_filter_valid_keys $key_values]] || [string equal $abstract_data_type date]} {
+
+ # Do some error checking
+ set key_values [km_sort_form $key_values]
+ set bad_input [km_check_input -required_p 1 $object_id $key_values]
+
+ if ![null_p $bad_input] {
+ ad_return_complaint [fst $bad_input] [snd $bad_input]
+ return
+ } else {
+ # Save the data
+ set results [km_save_object_data $object_id $user_id $key_values]
+ }
+
+} elseif { [string equal $abstract_data_type "category"] || [string equal $abstract_data_type "other_category"] } {
+
+ # We have to handle this differently because it is possible that
+ # no variable is carried thru from the one-question-edit.tcl, and
+ # yet this variable may be required.
+
+ if { [elem_p $question_id [km_required_questions $object_id]] } {
+ # Some important variable has not passed that is required
+ ad_return_complaint 1 " Locate the new owner:
+
+ Current owner history:
+ Locate the new publisher:
+
+ The current file was retrieved from
+
+
+
+
+
+
+
+ No user rating yet
+
+
+
+
+
+@access_count@ hits @ancestor_object_type@ @ancestor_name@ Date Created @date_created@ Release Date @pretty_checkoff_date@ Date Published @pretty_checkoff_date@ Last Modified
+
+@date_last_modified@ (History)
+
+
+
+@author_name@ Publisher
+
+ Publisher
+
+
+ @publisher_name@ More Links
+
+ Comments and Feedback
+
+
+
+
+
+Changed by
+ Changed from
+ Changed to
+ Changed on
+ Reason
+
+
+@history.ch_by;noquote@
+ @history.ch_from;noquote@
+ @history.ch_to;noquote@
+ @history.ch_date@
+ @history.ch_reason@
+
+
+ @formatted_value;noquote@
+
Index: openacs-4/contrib/obsolete-packages/library/www/question-field-child-object.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/question-field-child-object.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/question-field-child-object.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,23 @@
+# Displays child object types
+
+if {![info exists edit_p]} {
+ set edit_p 0
+}
+
+if {![info exists category_id]} {
+ set category_id ""
+}
+
+set user_id [ad_get_user_id]
+set children [map km_get_object_summary [km_get_child_objects $object_id $question_id]]
+
+if { $question_state != "read-only" || [km_conn admin_p] } {
+ set show_button_p t
+ set child_object_type_id [km_static question_target_object_type_id $question_id]
+ set child_object_type_plural [km_static object_type_pretty_plural $child_object_type_id]
+ set copy_p [km_static object_type_copy_p $child_object_type_id]
+ set child_object_type [km_static object_type_pretty_name $child_object_type_id]
+} else {
+ set show_button_p f
+}
+
Index: openacs-4/contrib/obsolete-packages/library/www/question-field-composite.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/question-field-composite.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/question-field-composite.adp 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,6 @@
+
+
+
+
+
+
Index: openacs-4/contrib/obsolete-packages/library/www/question-field-content-link.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/question-field-content-link.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/question-field-content-link.tcl 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,47 @@
+# Displays this field for a form field.
+# Lists all of the existing links between ACS content and this
+# object. Shows the button that leads to content linking excursion.
+
+if {![info exists value]} {
+ set value ""
+}
+
+if {![info exists edit_p]} {
+ set edit_p 0
+}
+
+if {![info exists category_id]} {
+ set category_id ""
+}
+
+if {![info exists size]} {
+ set size 30
+}
+
+if {![info exists maxlength]} {
+ set maxlength 50
+}
+
+if {![info exists hit_database_p]} {
+ set hit_database_p 1
+}
+
+if [empty_string_p $value] { set value "Link" }
+
+set return_url "one-question-edit?[export_url_vars object_id question_id category_id]"
+set path_vars [list question_id $question_id object_id $object_id category_id $category_id]
+set path_id [init_path $path_vars $return_url add_content_ref]
+set admin_p [km_conn admin_p]
+
+if { $question_state != "read-only" || [km_conn admin_p] } {
+ array set node [site_node_closest_ancestor_site_node "acs-subsite"]
+ set community_id $node(package_id)
+}
+
+if { $hit_database_p } {
+ set existing_links [km8_get_to_links $object_id $question_id]
+ set pass [ns_urlencode "$path_id:exclude [map fst $existing_links]"]
+} else {
+ set existing_links {}
+ set pass $path_id
+}
Index: openacs-4/contrib/obsolete-packages/library/www/question-field-date.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/question-field-date.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/question-field-date.adp 2 Jul 2003 12:19:43 -0000 1.1
@@ -0,0 +1,9 @@
+
+
"
+
+ @formatted_value;noquote@
+
+
You may also remove the file.
+
+
| |
|
+
+ |
+
| ||
| Existing links to @pretty_plural@ | ||
|---|---|---|
+
| |
+
| |
+ If you have chosen "Other" please specify. +
+ +
+
| |
+ +
= Answered
+
= Partly answered
+X = @question_state_deprecated;noquote@ or @question_state_read_only;noquote@+
= Reference to other knowledge objects
+
+* = Mandatory for publication
+... = More details (drilldown)
+
+| @check_img;noquote@ |
+ | @author_name@ |
| @check_img;noquote@ |
+ | @publisher_name@ |
| @check_img;noquote@ | @ancestor_object_type@ | @ancestor_name@ |
| @questions.check;noquote@ | +@questions.question_name@@questions.star;noquote@ @questions.arrow;noquote@ @questions.dots;noquote@ | +@questions.short_explanation;noquote@ |
+ +
+
![](\"graphics/check.gif\"){kind=small}
"
+set check_gray_img "![](\"graphics/check-gray.gif\"){kind=small}
"
+set pretty_type_name [km_static object_type_pretty_name $object_type_id]
+
+# This object may have some parents.
+# The proc returns pairs of parent_object_id and the object name
+set ancestors [reverse [km_get_object_ancestors $object_id]]
+if ![null_p $ancestors] {
+ set direct_ancestor [fst $ancestors]
+ set ancestor_object_id [fst $direct_ancestor]
+ set ancestor_name [snd $direct_ancestor]
+ set ancestor_object_type [km_static object_type_pretty_name [thd $direct_ancestor]]
+
+ db_1row get_public_archived_status {
+ select decode(public_p,'t',1,0) as ancestor_public_p,
+ decode(archived_p,'t',1,0) as ancestor_archived_p,
+ decode(in_review_p,'t',1,0) as ancestor_review_p
+ from sn_objects
+ where object_id = :ancestor_object_id
+ }
+ set child_p 1
+} else {
+ set child_p 0
+}
+
+set_the_usual_klib_context_bar $object_id $category_id
+append_context_bar_data "Questions"
+set nephew_p [km_is_nephew_p $object_id]
+
+if {$child_p && !$nephew_p} {
+ if {$ot_archive_p} {
+ set return_url "object-view?[export_url_vars object_id category_id]"
+ if { $archived_p && $edit_p } {
+ set object_access_toolbar "\[Archived\] Remove from archive"
+ } else {
+ set object_access_toolbar "Put in archive"
+ }
+ } else {
+ set object_access_toolbar ""
+ }
+} else {
+ set object_access_toolbar [km_object_access_toolbar $object_id $category_id]
+}
+
+# Get the questions that apply to this object type and indicate if
+# they have been answered or are links
+set question_states [list active deprecated read-only]
+if {$archived_p} {
+ lappend question_states invisible
+}
+set question_list [km_get_questions -question_states $question_states -all_properties_p 1 -root_node_p 1 -branch_children_p 1 -object_type_id $object_type_id -answered_p 1 -object_id $object_id]
+
+set key [head $question_list]
+set question_list [tail $question_list]
+set question_ids [fst [transpose [tail $question_list]]]
+
+# Go thru each question and decide to display it or not
+
+set abstract_data_type_ix [lsearch $key abstract_data_type]
+set question_state_ix [lsearch $key question_state]
+set branch_p_ix [lsearch $key branch_p]
+set root_branch_p_ix [lsearch $key root_branch_p]
+set entry_explanation_ix [lsearch $key entry_explanation]
+set question_id_ix [lsearch $key question_id]
+set question_name_ix [lsearch $key pretty_name]
+set mandatory_p_ix [lsearch $key mandatory_p]
+set answered_p_ix [lsearch $key answered_p]
+
+set questions_with_links [db_list_of_lists questions_10 {select unique question_id from (
+ select map.question_id,
+ acs_permission.permission_p(l.object_id_b, :user_id, 'sw_read') sw_read_p,
+ (select decode(count(*),0,'f','t') from dual where exists
+ (select decode(count(*),'f','t') from dual where exists
+ (select 1
+ from membership_rels mr_lm
+ where mr_lm.person_id = :user_id
+ and sn_group.group_list_members_p(mr_lm.group_id, l.object_id_b) > 0 ))) as user_list_p
+ from sn_links l, sn_question_link_map map, acs_objects ao
+ where l.object_id_a = :object_id
+ and l.object_id_b = ao.object_id
+ and l.link_id = map.link_id
+ ) where sw_read_p='t' or user_list_p='t'}]
+
+set i 0
+template::multirow create questions check destination_url question_name star arrow dots short_explanation question_state answered
+foreach question $question_list {
+ set abstract_data_type [lindex $question $abstract_data_type_ix]
+ set question_state [lindex $question $question_state_ix]
+ set branch_p [lindex $question $branch_p_ix]
+ set root_branch_p [lindex $question $root_branch_p_ix]
+ set arrow ""
+ set destination "one-question-edit?"
+ set explanation [lindex $question $entry_explanation_ix]
+ set question_id [lindex $question $question_id_ix]
+ set question_name [lindex $question $question_name_ix]
+ set mandatory_p [lindex $question $mandatory_p_ix]
+
+ # I think for questions of abstract data type options and categories are
+ # better checked in single queries.
+ set answered_p 0
+ switch $abstract_data_type {
+ "text" -
+ "file" -
+ "date" -
+ "integer" {
+ set answered_p [lindex $question $answered_p_ix]
+ }
+ "object_link" -
+ "user_link" -
+ "content_link" {
+ if {[lsearch $questions_with_links $question_id] < 0} {
+ set answered_p 0
+ } else {
+ set answered_p 1
+ }
+ }
+ "category" - "other_category" {
+ set answered_p [db_string questions_20 {select decode(count(*),0,0,1)
+ from dual
+ where exists
+ (select 'x'
+ from categories c, sw_flat_cat fc, sw_object_category_map cm, sn_questions q
+ where cm.object_id = :object_id
+ and q.question_id = :question_id
+ and fc.parent = q.node_id
+ and c.category_id = fc.child_category_id
+ and cm.category_id = c.category_id)}]
+ }
+ "option" {
+ set answered_p [db_string questions_20 {select decode(count(*),0,0,1)
+ from dual
+ where exists
+ (select 'x'
+ from sn_answer_options a, sn_object_option_map m
+ where a.option_id =m.option_id
+ and m.object_id = :object_id
+ and a.question_id = :question_id)}]
+ }
+ "child_object" {
+ set answer ""
+ set child_ids [km_get_child_objects $object_id $question_id]
+ foreach child_id $child_ids {
+ lappend answer [km_get_object_summary $child_id]
+ }
+ set answered_p [km_answered_p $abstract_data_type $answer]
+ }
+ "nephew_object" {
+ set answer ""
+ set nephew_ids [km_get_nephew_objects $object_id $question_id]
+ foreach nephew_id $nephew_ids {
+ lappend answer [km_get_object_summary $nephew_id]
+ }
+ set answered_p [km_answered_p $abstract_data_type $answer]
+ }
+ "composite" {
+ set child_ids [km_get_child_questions $question_id]
+ if {![null_p $child_ids]} {
+ set child_questions [km_get_questions -question_states {active deprecated read-only} -root_node_p 0 -question_ids $child_ids]
+ set answer [km_get_object_data -questions $child_questions -answers_only_p 0 $object_id]
+ set answered_p [km_answered_p $abstract_data_type $answer]
+ } else {
+ set answered_p 0
+ }
+ }
+ default {
+ ns_log Notice "Error in questions.tcl. I'm in the default branche and I shouldn't be there. Testing abstract_data_type $abstract_data_type of question $question_name"
+ set answer [km_get_object_data -questions [list question_id $question_id] $object_id]
+ set answered_p [km_answered_p $abstract_data_type $answer]
+ }
+ }
+
+
+ if { $abstract_data_type == "object_link" || \
+ $abstract_data_type == "user_link" || \
+ $abstract_data_type == "content_link" || \
+ $abstract_data_type == "child_object" || \
+ $abstract_data_type == "nephew_object"} {
+ set arrow "![](\"graphics/arrow.gif\"){kind=icon}
"
+ set destination "one-question-edit?"
+## set destination "object-link?"
+ }
+
+ if { $answered_p } {
+ if { $question_state == "active" } {
+ if { $abstract_data_type == "composite" } {
+ # If it's a composite question, we only mark it
+ # as answered if all children have been answered.
+
+ set all_answered_p 1
+ foreach item $answer {
+ set child_abstract_datatype [lindex $item 3]
+ set child_answer [fst $item]
+
+ if ![km_answered_p $child_abstract_datatype $child_answer] {
+ set all_answered_p 0
+ break
+ }
+ }
+
+ set check [ad_decode $all_answered_p 1 $check_img $check_gray_img]
+ set answered [ad_decode $all_answered_p 1 2 1]
+
+ } else {
+ set check $check_img
+ set answered 2
+ }
+ } else {
+ set check "X"
+ set answered 0
+ }
+ } else {
+ set check " "
+ set answered 0
+ }
+
+ # Set the question attributes using the key for the list variables
+ if { $mandatory_p == "t" } {
+ set star "*"
+ } else {
+ set star ""
+ }
+ if { $root_branch_p || $abstract_data_type == "composite" } {
+ set dots " ..."
+ } else {
+ set dots ""
+ }
+
+ set short_explanation [km_shorten_question $explanation]
+
+ if {[empty_string_p $branch_p]} {set branch_p 0}
+ if {$branch_p && [km_active_path_p $question_id $object_id $object_type_id]} {
+ set branch_p 0
+ set question_name "... $question_name"
+ }
+
+ if { ($question_state == "active" || $answered_p) &&
+ (($view_questions == "all" && !$branch_p) ||
+ ($view_questions == "unanswered" && !$answered_p && !$branch_p)) } {
+ # Display the row
+
+ template::multirow append questions $check "$destination[export_url_vars object_id category_id path_id question_id]" $question_name $star $arrow $dots $short_explanation $question_state $answered
+ }
+
+ incr i
+}
+
+ad_return_template
Index: openacs-4/contrib/obsolete-packages/library/www/resource-application-add-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/resource-application-add-2.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/resource-application-add-2.tcl 2 Jul 2003 12:19:44 -0000 1.1
@@ -0,0 +1,252 @@
+ad_page_contract {
+ /packages/library/www/resource-application-add-2.tcl
+
+ Show a form where a user can volunteer for an XchangeTask
+
+ @author Timo Hentschel (timo@arsdigita.com)
+ @cvs-id $Id: resource-application-add-2.tcl,v 1.1 2003/07/02 12:19:44 peterm Exp $
+} {
+ object_id:notnull,integer
+ resource_req_id:integer
+ {category_id ""}
+ {return_url "."}
+ apply:optional
+ cancel:optional
+} -properties {
+ title:onevalue
+ graphic:onevalue
+ graphic_width:onevalue
+ form_vars:onevalue
+ recipient:onevalue
+ role:onevalue
+ pretty_project_type:onevalue
+ subject:onevalue
+ system_url:onevalue
+ user_id:onevalue
+ contact_data:onevalue
+ nationality:onevalue
+ manager_email:onevalue
+ role_select:onevalue
+ role_other:onevalue
+ working_area:onevalue
+ first_language:onevalue
+ second_language_id:onevalue
+ third_language_id:onevalue
+ second_language_prof_id:onevalue
+ third_language_prof_id:onevalue
+ other_language:onevalue
+ languages:multirow
+ language_proficiencies:multirow
+ strengths:onevalue
+ leadership:onevalue
+ intercultural:onevalue
+ comments:onevalue
+ conditions:onevalue
+ attachments:multirow
+ dc_export:onevalue
+ edit_p:onevalue
+}
+csrf::authenticate
+
+set user_id [ad_maybe_redirect_for_registration]
+if ![km_check_object_id $object_id] { return }
+
+if ![exists_and_not_null resource_req_id] {
+ ad_return_complaint 1 "For some reason, resource_req_id has not been supplied with this request."
+ return
+}
+
+if {[info exists cancel]} {
+ ad_returnredirect $return_url
+}
+
+set demand_type_id [km_conn object_type_id]
+set pretty_demand_type [km_static object_type_pretty_name $demand_type_id]
+set demand_name [km_conn object_name]
+set role [snd [fst [fst [km_get_object_data $resource_req_id]]]]
+set graphic [km_static object_type_graphic $demand_type_id]
+set graphic_width [library_icon_width]
+
+set_the_usual_klib_context_bar $object_id $category_id
+append_context_bar_data "Apply"
+
+if ![km_check_object_id $resource_req_id] { return }
+set project_type_id [km_conn object_type_id]
+set pretty_project_type [km_static object_type_pretty_name $project_type_id]
+set project_name [km_conn object_name]
+
+set title "Volunteer for the $pretty_project_type \"$project_name\""
+set subject "I apply for the $pretty_demand_type \"$demand_name\" of the $pretty_project_type \"$project_name\""
+
+# All users that are linked to this Xchange task object
+# will get a copy of the mail.
+
+set recipient [sn_people_responsible $user_id $object_id]
+
+set form_vars [export_form_vars object_id resource_req_id category_id return_url recipient]
+set system_url [ad_url]
+
+# Now let's get some info about the volunteer.
+
+db_1row get_user_data {
+ select email as user_email, first_names || ' ' || last_name as user_name
+ from users
+ where user_id = :user_id
+}
+
+set contact_data "Name: $user_name\nEmail: $user_email\n"
+db_foreach get_global_questions {
+ select q.question_id, q.question,
+ decode ( q.category_tree_id, null, a.answer, c.short_name ) as answer
+ from sn_reg_questions q, sn_reg_answers a, categories c
+ where q.scope = 'site_wide'
+ and q.deleted_p = 'f'
+ and q.question_id = a.question_id(+)
+ and a.category_id = c.category_id(+)
+ and a.user_id(+) = :user_id
+} {
+ append contact_data "$question: $answer\n"
+}
+
+set edit_p 0
+util_unlist [km_break_date [db_string get_sysdate {select sysdate from dual}]] from_year from_month from_day
+set to_year $from_year
+set to_month $from_month
+set to_day $from_day
+set nationality ""
+set manager_email ""
+set working_area ""
+set first_language ""
+set second_language_id ""
+set third_language_id ""
+set second_language_prof_id ""
+set third_language_prof_id ""
+set other_language ""
+set strengths ""
+set leadership ""
+set intercultural ""
+set comments ""
+set conditions ""
+template::multirow create attachments attachment_id filename title size
+
+set package_id [ad_conn package_id]
+set magic_ids_exist_p [db_0or1row get_magic_ids_for_category_trees {
+ select role_magic_id, language_magic_id, proficiency_magic_id
+ from psn_category_trees
+ where package_id = :package_id
+}]
+
+if {!$magic_ids_exist_p} {
+ ad_return_complaint 1 "Error in library setup. No magic ids for category trees for the application form found."
+ return
+}
+
+if {!$role_magic_id} {
+ ad_return_complaint 1 "No category tree assigned for roles. Please contact a library administrator."
+ return
+}
+if {!$language_magic_id} {
+ ad_return_complaint 1 "No category tree assigned for languages. Please contact a library administrator."
+ return
+}
+if {!$proficiency_magic_id} {
+ ad_return_complaint 1 "No category tree assigned for language proficiencies. Please contact a library administrator."
+ return
+}
+
+
+set role_category_tree_assigned_p [db_0or1row role_category_tree {
+ select octr.subtree_root_node_id as role_subtree_root_id,
+ gt.root_node_id as role_orig_root_id
+ from generic_trees gt,
+ acs_rels ar,
+ object_category_tree_rels octr
+ where ar.object_id_one = :role_magic_id
+ and ar.object_id_two = gt.tree_id
+ and ar.rel_id = octr.rel_id
+ and rel_type = 'object_category_tree_rel'}]
+
+if {!$role_category_tree_assigned_p} {
+ ad_return_complaint 1 "No category tree assigned for roles. Please contact a library administrator."
+ return
+}
+
+if { $role_subtree_root_id == $role_orig_root_id } {
+ set role_level_correction 1
+} else {
+ set role_level_correction 0
+}
+
+set language_category_tree_assigned_p [db_0or1row language_category_tree {
+ select octr.subtree_root_node_id as language_subtree_root_id,
+ gt.root_node_id as language_orig_root_id
+ from generic_trees gt,
+ acs_rels ar,
+ object_category_tree_rels octr
+ where ar.object_id_one = :language_magic_id
+ and ar.object_id_two = gt.tree_id
+ and ar.rel_id = octr.rel_id
+ and rel_type = 'object_category_tree_rel'}]
+
+if {!$language_category_tree_assigned_p} {
+ ad_return_complaint 1 "No category tree assigned for languages. Please contact a library administrator."
+ return
+}
+
+if { $language_subtree_root_id == $language_orig_root_id } {
+ set language_level_correction 1
+} else {
+ set language_level_correction 0
+}
+
+set proficiency_category_tree_assigned_p [db_0or1row proficiency_category_tree {
+ select octr.subtree_root_node_id as proficiency_subtree_root_id,
+ gt.root_node_id as proficiency_orig_root_id
+ from generic_trees gt,
+ acs_rels ar,
+ object_category_tree_rels octr
+ where ar.object_id_one = :proficiency_magic_id
+ and ar.object_id_two = gt.tree_id
+ and ar.rel_id = octr.rel_id
+ and rel_type = 'object_category_tree_rel'}]
+
+if {!$proficiency_category_tree_assigned_p} {
+ ad_return_complaint 1 "No category tree assigned for language proficiencies. Please contact a library administrator."
+ return
+}
+
+if { $proficiency_subtree_root_id == $proficiency_orig_root_id } {
+ set proficiency_level_correction 1
+} else {
+ set proficiency_level_correction 0
+}
+
+set role_select ""
+
+template::multirow create languages language_id name
+set language_results [util_memoize [list swc_get_category_tree $language_subtree_root_id 0 {}]]
+foreach language $language_results {
+ util_unlist $language category_id category_name category_description
+ template::multirow append languages $category_id $category_name
+}
+
+template::multirow create language_proficiencies prof_id name
+set prof_results [util_memoize [list swc_get_category_tree $proficiency_subtree_root_id 0 {}]]
+foreach prof $prof_results {
+ util_unlist $prof category_id category_name category_description
+ template::multirow append language_proficiencies $category_id $category_name
+}
+
+set role_other ""
+
+set dc_export [doubleclick::signature_html]
+
+db_release_unused_handles
+
+ad_return_template resource-application
Index: openacs-4/contrib/obsolete-packages/library/www/resource-application-add.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/resource-application-add.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/resource-application-add.adp 2 Jul 2003 12:19:44 -0000 1.1
@@ -0,0 +1,18 @@
+"I hereby confirm that I have consulted my direct line manager about the possible transfer. He agrees with this application." +
+ +
Index: openacs-4/contrib/obsolete-packages/library/www/resource-application-add.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/resource-application-add.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/resource-application-add.tcl 2 Jul 2003 12:19:44 -0000 1.1 @@ -0,0 +1,55 @@ +ad_page_contract { + /packages/library/www/resource-application-add.tcl + + Show a confirmation form or redirect to saved and unsent form + + @author Timo Hentschel (timo@arsdigita.com) + @cvs-id $Id: resource-application-add.tcl,v 1.1 2003/07/02 12:19:44 peterm Exp $ +} { + object_id:notnull,integer + resource_req_id:integer + {category_id ""} + {return_url "."} +} -properties { + title:onevalue + form_vars:onevalue + project_graphic:onevalue + graphic_width:onevalue +} + +set user_id [ad_maybe_redirect_for_registration] +if ![km_check_object_id $object_id] { return } + +if ![exists_and_not_null resource_req_id] { + ad_return_complaint 1 "For some reason, resource_req_id has not been supplied with this request." + return +} + +set unfinished_applications_p [db_0or1row get_unfinished_applications { + select application_id + from psn_res_applications + where sent_p = 'f' + and object_id = :object_id + and resource_req_id = :resource_req_id + and user_id = :user_id +}] + +if {$unfinished_applications_p} { + ad_returnredirect "resource-application-edit?[export_url_vars application_id category_id return_url]" +} + +set project_type_id [km_conn object_type_id] + set pretty_project_type [km_static object_type_pretty_name $project_type_id] +set project_graphic [km_static object_type_graphic $project_type_id] +set project_name [km_conn object_name] +set title "Apply for $pretty_project_type \"$project_name\"" +set graphic_width [library_icon_width] + +set_the_usual_klib_context_bar $object_id $category_id +append_context_bar_data "Confirm" + +set form_vars [export_form_vars object_id resource_req_id category_id return_url] + +db_release_unused_handles + +ad_return_template Index: openacs-4/contrib/obsolete-packages/library/www/resource-application-attach-2.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/resource-application-attach-2.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/resource-application-attach-2.tcl 2 Jul 2003 12:19:44 -0000 1.1 @@ -0,0 +1,55 @@ +ad_page_contract { + script to recieve the new file and insert it into the database + + @author Timo Hentschel (timo@arsdigita.com) + @creation-date 26 Oct 2001 + @cvs-id $Id: resource-application-attach-2.tcl,v 1.1 2003/07/02 12:19:44 peterm Exp $ +} { + application_id:integer,notnull + {category_id ""} + return_url:notnull + upload_file:notnull,trim + upload_file.tmpfile:tmpfile +} +csrf::authenticate + +set user_id [ad_maybe_redirect_for_registration] +set target "resource-application-edit?[export_url_vars application_id category_id return_url]" + +if {[doubleclick::check_all]} { + ns_sleep 2 + ad_returnredirect $target + return +} + +# get the filename part of the upload file +if ![regexp {[^//\\]+$} $upload_file filename] { + # no match + set filename $upload_file +} + +set mime_type [ns_guesstype $upload_file] + +db_transaction { + + set attachment_id [db_nextval "psn_attachment_id_seq"] + + db_dml insert_attachment { + insert into psn_attachments + (attachment_id, application_id, title, mime_type, filename) + values + (:attachment_id, :application_id, :filename, :mime_type, :filename) + } + + db_dml add_attachment_to_application { + update psn_attachments + set attachment = empty_blob() + where attachment_id = :attachment_id + returning attachment into :1 + } -blob_files [list ${upload_file.tmpfile}] + +} + +db_release_unused_handles + +ad_returnredirect $target Index: openacs-4/contrib/obsolete-packages/library/www/resource-application-attach.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/resource-application-attach.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/resource-application-attach.adp 2 Jul 2003 12:19:44 -0000 1.1 @@ -0,0 +1,34 @@ +Result page:
+
+
$errmsg" + return +} + +ad_returnredirect $page_url Index: openacs-4/contrib/obsolete-packages/library/www/send-page-ref.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/send-page-ref.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/send-page-ref.adp 2 Jul 2003 12:19:44 -0000 1.1 @@ -0,0 +1,14 @@ +
Locate your colleague by + +
Index: openacs-4/contrib/obsolete-packages/library/www/send-page-ref.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/send-page-ref.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/send-page-ref.tcl 2 Jul 2003 12:19:44 -0000 1.1 @@ -0,0 +1,38 @@ +ad_page_contract { + /www/library/send-page-ref.tcl + + Let the user select the recipient to which he wants to send an HREF. + + @cvs-id $Id: send-page-ref.tcl,v 1.1 2003/07/02 12:19:44 peterm Exp $ +} { + page_url:notnull + return_title:notnull + object_id:notnull + {category_id ""} +} -properties { + title:onevalue + form_vars:onevalue +} + +ad_maybe_redirect_for_registration +if {![km_check_object_id $object_id]} { + return +} + + +if ![km_check_object_id $object_id] { return } +set_the_usual_klib_context_bar $object_id $category_id +append_context_bar_data "Send to colleague" +set title "Send a Page to a Colleague" +set target "send-page-ref-2" +set passthrough {page_url return_title object_id category_id} +set context_bar [list "send-page-ref?[export_url_vars page_url return_title object_id category_id]" "Send to colleague"] +set show_myself_p f + +# Because of Siemens' IMS application proxy, we have to make sure +# that page_url doesn't start with a "/". +set page_url "-$page_url" + +set form_vars [export_form_vars show_myself_p target passthrough context_bar page_url return_title object_id category_id] + +ad_return_template Index: openacs-4/contrib/obsolete-packages/library/www/show-descriptions.adp =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/show-descriptions.adp,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/show-descriptions.adp 2 Jul 2003 12:19:44 -0000 1.1 @@ -0,0 +1,16 @@ +-
+
- @categories.item;noquote@
- @categories.description@ +
+ +
| + + | ++ + | +
+ +
+
Index: openacs-4/contrib/obsolete-packages/library/www/admin/branch-tree.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/admin/branch-tree.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/admin/branch-tree.tcl 2 Jul 2003 12:19:44 -0000 1.1 @@ -0,0 +1,41 @@ +ad_page_contract { + /packages/library/www/admin/branch-tree.tcl + + @author Carsten Clasohm (carsten@arsdigita.com) + @author Dirk Gomez (dirk@arsdigita.com) + + @cvs-id $Id: branch-tree.tcl,v 1.1 2003/07/02 12:19:44 peterm Exp $ +} { + object_type_id +} -properties { + questions:multirow +} + +# Object type info for page display +set pretty_type [km_static object_type_pretty_name $object_type_id] +set graphic [km_static object_type_graphic $object_type_id] +set graphic_width [library_icon_width] + +set sql_branch_tree_10 " +select question_id, level +from sn_question_object_type_map +where object_type_id = $object_type_id + and (branch_p = 't' + or question_id in (select parent_question_id from sn_question_object_type_map where branch_p = 't' and object_type_id = $object_type_id)) +start with parent_question_id=[km_static km_dummy_object_id] and object_type_id=$object_type_id + and question_id in (select parent_question_id from sn_question_object_type_map where object_type_id = $object_type_id) +connect by prior question_id = parent_question_id and object_type_id = $object_type_id" + +# Construct a tree with links to the individual branches + +template::multirow create questions indentation_level indentation link +db_foreach branch_tree_10 $sql_branch_tree_10 { + set pretty_question [snd [km_get_question $question_id $object_type_id]] + + template::multirow append questions $level [space -size [expr $level *5]] "$pretty_question" + +} + +set title "Branch Tree for $pretty_type" +set_context_bar_data [list "view-questions?object_type_id=$object_type_id" "$pretty_type Questions"] $title +ad_return_template Index: openacs-4/contrib/obsolete-packages/library/www/admin/choose-category-2.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/admin/choose-category-2.tcl,v diff -u --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/contrib/obsolete-packages/library/www/admin/choose-category-2.tcl 2 Jul 2003 12:19:44 -0000 1.1 @@ -0,0 +1,70 @@ +ad_page_contract { + /packages/library/www/admin/create-category-2.tcl + + @author Carsten Clasohm (carsten@arsdigita.com) + @author Dirk Gomez (dirk@arsdigita.com) + @author Jens Kordsmeier (jak@arsdigita.com) + + @cvs-id $Id: choose-category-2.tcl,v 1.1 2003/07/02 12:19:44 peterm Exp $ +} { + question_id + object_type_id + tree_id + reset_categorization:optional +} -properties { +} +csrf::authenticate + +# Get node_id for tree root +set node_id [db_string get_root_node { + select root_node_id + from generic_trees + where tree_id = :tree_id +}] + +# Test if another visible question is already using this category. +set used_p [db_string check_uniqueness { + select count(*) + from sn_questions q, sn_question_object_type_map qm + where q.node_id = :node_id + and q.question_id = qm.question_id + and qm.object_type_id = :object_type_id + and qm.question_state <> 'invisible' + and q.question_id <> :question_id +}] + +if { $used_p } { + ad_return_complaint 1 "
Please select the category tree for question +@pretty_question@ of object type +@pretty_type@ below. + +
Question @pretty_question@ is associated with category
+tree @tree_name@.
You may either edit
+this category tree, or assign a different tree below.
+
+
When you assign a new tree, you may remove existing object +categorizations for the newly assigned tree. This is useful when the +tree was used for a different question of this object type in the +past. + +
+ +Administer Categories
Index: openacs-4/contrib/obsolete-packages/library/www/admin/choose-category.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/admin/choose-category.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/admin/choose-category.tcl 2 Jul 2003 12:19:44 -0000 1.1
@@ -0,0 +1,68 @@
+ad_page_contract {
+ /packages/library/www/admin/choose-category.tcl
+
+ After creating a new question, let the user associate it
+ with a category tree.
+
+ @author Carsten Clasohm (carsten@arsdigita.com)
+ @author Dirk Gomez (dirk@arsdigita.com)
+ @author Jens Kordsmeier (jak@arsdigita.com)
+
+ @cvs-id $Id: choose-category.tcl,v 1.1 2003/07/02 12:19:44 peterm Exp $
+} {
+ question_id
+ object_type_id
+} -properties {
+}
+
+set pretty_type [km_static object_type_pretty_name $object_type_id]
+set pretty_plural [km_static object_type_pretty_plural $object_type_id]
+set graphic [km_static object_type_graphic $object_type_id]
+
+set user_id [ad_verify_and_get_user_id]
+
+set tree_id [db_string get_current_tree {
+ select tree_id
+ from sn_questions
+ where question_id = :question_id
+}]
+
+db_multirow category_trees category_trees "
+ select g.tree_id, g.tree_name
+ from generic_tree_types t, generic_trees g
+ where t.tree_struct_table = 'sw_category_dim'
+ and t.type_id = g.type_id
+ and g.hidden_p = 'f'
+ and (g.site_wide_p = 't'
+ [ad_decode $tree_id "" "" "or g.tree_id = :tree_id"]
+ or [tcl_permission_for_bind_vars_p "g.tree_id" ":user_id" "'category_tree_read'"] = 't')
+ and g.root_node_id not in (select q.node_id
+ from sn_questions q, sn_question_object_type_map qm
+ where q.node_id is not null
+ and q.question_id = qm.question_id
+ and qm.object_type_id = :object_type_id
+ and qm.question_state <> 'invisible'
+ and q.question_id <> :question_id)
+ order by lower(tree_name)
+"
+
+set pretty_question [snd [km_get_question $question_id $object_type_id]]
+
+set title "Categories"
+set_context_bar_data \
+ [list "view-questions?object_type_id=$object_type_id" "$pretty_type Questions"] \
+ $title
+
+if { [empty_string_p $tree_id] } {
+ set tree_name ""
+} else {
+ set tree_name [db_string choose_category_10 {
+ select tree_name
+ from generic_trees
+ where tree_id = :tree_id
+ }]
+}
+
+set form_vars [export_form_vars question_id object_type_id]
+
+ad_return_template
Index: openacs-4/contrib/obsolete-packages/library/www/admin/choose-object-type.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/admin/choose-object-type.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/admin/choose-object-type.adp 2 Jul 2003 12:19:44 -0000 1.1
@@ -0,0 +1,28 @@
+
+
+
+
+
+
+
Index: openacs-4/contrib/obsolete-packages/library/www/admin/choose-object-type.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/admin/choose-object-type.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/admin/choose-object-type.tcl 2 Jul 2003 12:19:44 -0000 1.1
@@ -0,0 +1,37 @@
+ad_page_contract {
+ /packages/library/www/admin/choose-object-type.tcl
+
+ @author Carsten Clasohm (carsten@arsdigita.com)
+ @author Dirk Gomez (dirk@arsdigita.com)
+ @author Jens Kordsmeier (jak@arsdigita.com)
+
+ @cvs-id $Id: choose-object-type.tcl,v 1.1 2003/07/02 12:19:44 peterm Exp $
+} {
+ question_id
+ object_type_id
+ abstract_data_type
+} -properties {
+ title:onevalue
+ abstract_data_type:onevalue
+ pretty_type:onevalue
+ submit_button_html:onevalue
+ object_types:multirow
+}
+
+# Object type info for page display
+set pretty_type [km_static object_type_pretty_name $object_type_id]
+set graphic [km_static object_type_graphic $object_type_id]
+
+template::multirow create object_types object_input_type
+set checked "checked"
+foreach type [km_get_all_object_types -browsable_only_p 0] {
+ template::multirow append object_types " [snd $type]
"
+ set checked ""
+}
+
+
+set title "Choose Object Type"
+set_context_bar_data [list "view-questions?object_type_id=$object_type_id" "$pretty_type Questions"] $title
+set form_vars [export_form_vars question_id object_type_id abstract_data_type]
+
+
Index: openacs-4/contrib/obsolete-packages/library/www/admin/choose-presentation-type-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/admin/choose-presentation-type-2.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/admin/choose-presentation-type-2.tcl 2 Jul 2003 12:19:44 -0000 1.1
@@ -0,0 +1,37 @@
+ad_page_contract {
+ /packages/library/www/admin/
+
+ @author Carsten Clasohm (carsten@arsdigita.com)
+ @author Dirk Gomez (dirk@arsdigita.com)
+ @author Jens Kordsmeier (jak@arsdigita.com)
+
+ @cvs-id $Id: choose-presentation-type-2.tcl,v 1.1 2003/07/02 12:19:44 peterm Exp $
+} {
+ question_id:integer,notnull
+ presentation_type
+ object_type_id:integer,notnull
+ {tag_height:integer ""}
+ {tag_width:integer ""}
+ {year_from:integer "-5"}
+ {year_to:integer "5"}
+}
+csrf::authenticate
+
+if {[empty_string_p $tag_height]} { set tag_height [db_null] }
+if {[empty_string_p $tag_width]} {set tag_width [db_null] }
+if {[empty_string_p $year_from]} { set year_from [db_null] }
+if {[empty_string_p $year_to]} {set year_to [db_null] }
+
+db_dml choose_presentation_type_2 {
+ update sn_questions set
+ presentation_type = :presentation_type,
+ tag_height = :tag_height,
+ tag_width = :tag_width,
+ year_from = :year_from,
+ year_to = :year_to
+ where question_id = :question_id
+}
+
+km_static -reset $question_id
+
+ad_returnredirect "view-questions?[export_url_vars object_type_id]"
Index: openacs-4/contrib/obsolete-packages/library/www/admin/choose-presentation-type.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/contrib/obsolete-packages/library/www/admin/choose-presentation-type.adp,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/contrib/obsolete-packages/library/www/admin/choose-presentation-type.adp 2 Jul 2003 12:19:44 -0000 1.1
@@ -0,0 +1,51 @@
+