Index: openacs-4/packages/adserver/tcl/adserver-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/adserver/tcl/adserver-procs.tcl,v
diff -u -r1.7 -r1.8
--- openacs-4/packages/adserver/tcl/adserver-procs.tcl 12 Feb 2019 18:00:04 -0000 1.7
+++ openacs-4/packages/adserver/tcl/adserver-procs.tcl 12 Feb 2019 18:45:14 -0000 1.8
@@ -1,27 +1,27 @@
ad_library {
- definitions for the ad server; adserver_get_ad_html is called by
- .tcl, .adp, or .html pages (by filters, presumably) to generate ad
- IMGs (linked to HREFs). An API for managing database queries.
+ definitions for the ad server; adserver_get_ad_html is called by
+ .tcl, .adp, or .html pages (by filters, presumably) to generate ad
+ IMGs (linked to HREFs). An API for managing database queries.
- @creation-date 11/15/2000
- @author modified 11/15/2000 by jerry@hollyjerry.org
- @author modified 07/13/2000 by mchu@arsdigita.com
- @cvs-id $Id$
+ @creation-date 11/15/2000
+ @author modified 11/15/2000 by jerry@hollyjerry.org
+ @author modified 07/13/2000 by mchu@arsdigita.com
+ @cvs-id $Id$
}
############################################################
### internal cache helper function
############################################################
ad_proc -private adserver_cache_refresh {} {
- } {
- return [util_memoize {adserver_cache_refresh_mem} 300]
+} {
+ return [util_memoize {adserver_cache_refresh_mem} 300]
}
ad_proc -private adserver_cache_refresh_mem {} {
- } {
- return [ad_parameter -package_id [ad_acs_adserver_id] CacheRefresh 600]
+} {
+ return [ad_parameter -package_id [ad_acs_adserver_id] CacheRefresh 600]
}
@@ -36,7 +36,7 @@
### our package id
ad_proc -public ad_acs_adserver_id {} {
@return The object id of the adserver if it exists, 0 otherwise.
- } {
+} {
return [util_memoize {ad_acs_adserver_id_mem} 300]
}
@@ -47,24 +47,24 @@
where package_key = 'adserver'
} -default 0]
} else {
- return 0
+ return 0
}
}
-
+
### the url to get to an ad
ad_proc -public ad_acs_adserver_url {} {
@return The url of the adserver mountpoint if it exists, 0 otherwise.
- } {
+} {
return [util_memoize {ad_acs_adserver_url_mem} [adserver_cache_refresh]]
}
ad_proc -private ad_acs_adserver_url_mem {} {} {
if {[db_table_exists apm_packages]} {
return [db_string acs_adserver_mountpoint {
select site_node.url(s.node_id)
- from site_nodes s, apm_packages a
- where s.object_id = a.package_id
- and a.package_key = 'adserver'
+ from site_nodes s, apm_packages a
+ where s.object_id = a.package_id
+ and a.package_key = 'adserver'
} -default 0]
} else {
return 0
@@ -73,8 +73,8 @@
ad_proc -public ad_acs_adserver_pageroot {} {
@return The pathname in the filesystem of the adserver www/ directory
- } {
- return [util_memoize {ad_acs_adserver_pageroot_mem} [adserver_cache_refresh]]
+} {
+ return [util_memoize {ad_acs_adserver_pageroot_mem} [adserver_cache_refresh]]
}
ad_proc -private ad_acs_adserver_pageroot_mem {} {} {
@@ -86,117 +86,117 @@
############################################################
ad_proc -public adserver_get_ad_html {
- {-user_id ""}
+ {-user_id ""}
{-method ""}
{-ad_number ""}
{-suppress_logging:boolean}
{-adv_key ""}
{group_key ""}
{extra_img_tags "border=0"}
- } {
- Gets an ad. Try's to make it user specific.
+} {
+ Gets an ad. Try's to make it user specific.
- If method is not supplied, it uses the natural ad
- selection method of the group. Otherwise, it follows method,
- which may be one of least-exposure-first, sequential,
- or random.
+ If method is not supplied, it uses the natural ad
+ selection method of the group. Otherwise, it follows method,
+ which may be one of least-exposure-first, sequential,
+ or random.
- if the ad_number is not blank, it should be an integer specifying
- the number of the ad within a group to be retrieved.
+ if the ad_number is not blank, it should be an integer specifying
+ the number of the ad within a group to be retrieved.
- extra_img_tags are not used if track_clickthru is not set
-
- the string $timestamp in the url will be replaced with the
- current timestamp
+ extra_img_tags are not used if track_clickthru is not set
- } {
+ the string $timestamp in the url will be replaced with the
+ current timestamp
- ############################################
- ### part one: build sql to find the right ad
- ############################################
+} {
+############################################
+### part one: build sql to find the right ad
+############################################
+
if {![string equal $adv_key ""]} {
set sql_query "
- select track_clickthru_p, target_url
- from advs
- where adv_key = :adv_key
+ select track_clickthru_p, target_url
+ from advs
+ where adv_key = :adv_key
"
set query_name adserver_get_ad_by_ad_key
} elseif {[string equal $group_key ""]} {
-
- if {[string is integer -strict $ad_number]} {
+
+ if {[string is integer -strict $ad_number]} {
set sql_query "
- select track_clickthru_p, target_url, adv_key
- from advs
- where adv_number = :ad_number
+ select track_clickthru_p, target_url, adv_key
+ from advs
+ where adv_number = :ad_number
"
set query_name adserver_get_ad_by_adnumber
} else {
set adv_key [adserver_get_random_ad_key]
set query_name adserver_get_ad_by_ad_key
set sql_query "
- select track_clickthru_p, target_url
- from advs
- where adv_key=:adv_key"
+ select track_clickthru_p, target_url
+ from advs
+ where adv_key=:adv_key"
}
} else {
if {[string is integer -strict $ad_number]} {
- set query_name adserver_get_ad_by_group_and_number
+ set query_name adserver_get_ad_by_group_and_number
set sql_query "
- select a.adv_key, track_clickthru_p, target_url
- from advs a, adv_group_map m
- where a.adv_key = m.adv_key
- and adv_group_number = :ad_number
- and m.group_key = :group_key
- "
+ select a.adv_key, track_clickthru_p, target_url
+ from advs a, adv_group_map m
+ where a.adv_key = m.adv_key
+ and adv_group_number = :ad_number
+ and m.group_key = :group_key
+ "
} else {
if {[string equal "" $method]} {
set query_name adserver_get_ad_by_method
set rotation_method [db_string ad_rotation_method "
- select rotation_method
- from adv_groups
- where group_key=:group_key" -default ""]
-
+ select rotation_method
+ from adv_groups
+ where group_key=:group_key" -default ""]
+
set rotation_method [string trim $rotation_method]
} else {
set rotation_method $method
}
-
+
switch $rotation_method {
least-exposure-first {
set query_name adserver_get_ad_least_exposure_first
set sql_query "
select map.adv_key, track_clickthru_p, target_url
- from adv_group_map map, advs_todays_log log, advs
- where rownum=1
- and group_key = :group_key
- and map.adv_key = advs.adv_key
- and map.adv_key = log.adv_key (+)
- order by nvl (display_count, 0)"
+ from adv_group_map map, advs_todays_log log, advs
+ where rownum=1
+ and group_key = :group_key
+ and map.adv_key = advs.adv_key
+ and map.adv_key = log.adv_key (+)
+ order by nvl (display_count, 0)"
}
user-sequential {
-# note -- logging must be on, and this switch should be sequential
+ # note -- logging must be on, and this switch should be sequential
set query_name adserver_get_ad_by_ad_key
if {[string equal "" $user_id]} {
set user_id [ad_get_user_id]
}
-
+
set adv_key [adserver_get_sequential_ad_key \
- -user_id $user_id $group_key]
+ -user_id $user_id $group_key]
set sql_query "
select track_clickthru_p, target_url
- from advs
- where adv_key=:adv_key"
+ from advs
+ where adv_key=:adv_key"
}
random -
default {
set query_name adserver_get_ad_by_ad_key
set adv_key [adserver_get_random_ad_key $group_key]
set sql_query "
select track_clickthru_p, target_url from advs
- where adv_key=:adv_key"
- }
+ where adv_key=:adv_key"
+ }
}
}
}
@@ -207,13 +207,13 @@
##########################################
if {![db_0or1row $query_name $sql_query]} {
- # couldn't even find one row, use the default ad
+ # couldn't even find one row, use the default ad
ns_log warning "adserver_get_ad_html asked for an ad " \
- "in the $group_key group but there aren't any (adv_key is $adv_key)"
+ "in the $group_key group but there aren't any (adv_key is $adv_key)"
set target_url \
[ad_parameter \
- -package_id [ad_acs_adserver_id] \
+ -package_id [ad_acs_adserver_id] \
DefaultAdTargetURL /]
set track_clickthru_p t
set adv_key default
@@ -223,54 +223,54 @@
# wrapped in an adhref href. If track_clickthru_p is
# false, just spew out the html contained in target_url forget
# about it. This is how we deal with doubleclick and their ild
-
+
######################################################
### part three: generate the html
### track the impression now, if necessary
### or spit out doubleclickish url
######################################################
- set s_url [adserver_src_attr \
- -suppress_logging=$suppress_logging_p \
- -adv_key $adv_key]
+ set s_url [adserver_src_attr \
+ -suppress_logging=$suppress_logging_p \
+ -adv_key $adv_key]
if {[string equal $track_clickthru_p t]} {
set h_url [adserver_href_attr \
- -suppress_logging=$suppress_logging_p \
- -adv_key $adv_key $target_url]
+ -suppress_logging=$suppress_logging_p \
+ -adv_key $adv_key $target_url]
set result \
- "<a href='$h_url'><img src='$s_url' $extra_img_tags></a>"
+ "<a href='$h_url'><img src='$s_url' $extra_img_tags></a>"
} else {
set result "<a href=\"$target_url\"><img src='$s_url' $extra_img_tags></a>"
# update the impressions since this won't get called
# through adimg.tcl
db_dml adserver_defs_adv_update "
- update adv_log
- set display_count = display_count + 1
- where adv_key = :adv_key
- and entry_date = trunc (sysdate)"
-
+ update adv_log
+ set display_count = display_count + 1
+ where adv_key = :adv_key
+ and entry_date = trunc (sysdate)"
+
set n_rows [db_resultrows]
-
+
if { $n_rows == 0 } {
- # there wasn't a row in the database; we can't just do
- # the obvious insert because another thread might be
- # executing concurrently
+ # there wasn't a row in the database; we can't just do
+ # the obvious insert because another thread might be
+ # executing concurrently
db_dml adv_insert "
- insert into adv_log
- (adv_key, entry_date, display_count)
- values (:adv_key,
- trunc (sysdate),
- (select 1 from dual
- where 0 = (select count (*)
- from adv_log
- where adv_key = :adv_key
- and entry_date = trunc (sysdate))))"
+ insert into adv_log
+ (adv_key, entry_date, display_count)
+ values (:adv_key,
+ trunc (sysdate),
+ (select 1 from dual
+ where 0 = (select count (*)
+ from adv_log
+ where adv_key = :adv_key
+ and entry_date = trunc (sysdate))))"
}
-
+
if {[ad_conn -connected_p]} {
if {[util_memoize {
@@ -307,39 +307,39 @@
### pick a random ad
### dumb routine really, ads should not be randomly picked
ad_proc adserver_get_random_ad_key {{group_key ""}} {
- Returns random adv key
- } {
+ Returns random adv key
+} {
if {[string equal "" $group_key]} {
-
- # no group given, pick an ad at random
+
+ # no group given, pick an ad at random
set n_available [db_string adserver_count_group_ads "
- select adv_count
- from advs_properties
+ select adv_count
+ from advs_properties
" -default 0]
set adv_key ""
# pick an ad, any ad
if { $n_available > 0} {
set pick [ns_rand $n_available]
set adv_key [db_string adserver_pick "
- select adv_key
- from advs
- where adv_number = :pick
+ select adv_key
+ from advs
+ where adv_number = :pick
" -default ""]
}
# return the ad you picked (may be "")
return $adv_key
} else {
-
- # count the ads in the group
+
+ # count the ads in the group
set n_available [db_string adserver_count_group_ads "
- select adv_count
- from adv_groups
- where group_key = :group_key
+ select adv_count
+ from adv_groups
+ where group_key = :group_key
" -default 0]
-
+
# if none are present in the group, pick a random ad from all ads
if {$n_available == 0} {
ns_log warning adserver: non existent group $group_key
@@ -348,13 +348,13 @@
# pick a random ad from the group
set pick [ns_rand $n_available]
-
+
# select the ad_key for that ad
set adv_key [db_string adserver_group_get "
- select adv_key
- from adv_group_map
- where adv_group_number = :pick
- and group_key = :group_key
+ select adv_key
+ from adv_group_map
+ where adv_group_number = :pick
+ and group_key = :group_key
" -default ""]
# if it's blank, pick a random ad from all ads
@@ -369,68 +369,68 @@
### get the "next" ad in a sequence
ad_proc adserver_get_sequential_ad_key { {-user_id ""} group_key} {
Returns sequential adv_key
- } {
+} {
if {[string equal "" $user_id]} {
set user_id [ad_get_user_id]
}
set selection [db_0or1row adserver_adv_key {
select adv_group_number as last,
- ag.adv_count, '0' as max_adv_group_number
- from adv_group_map grp, adv_groups ag, adv_user_map map
- where user_id=:user_id
- and event_time = (
- select max(event_time)
- from adv_user_map map2
- where map2.user_id = :user_id
- and map2.adv_key = map.adv_key
- and map2.event_type = 'd'
- )
- and ag.group_key = :group_key
- and grp.group_key = :group_key
- and grp.adv_key = map.adv_key
- and map.user_id = :user_id
- and map.event_type = 'd'}]
+ ag.adv_count, '0' as max_adv_group_number
+ from adv_group_map grp, adv_groups ag, adv_user_map map
+ where user_id=:user_id
+ and event_time = (
+ select max(event_time)
+ from adv_user_map map2
+ where map2.user_id = :user_id
+ and map2.adv_key = map.adv_key
+ and map2.event_type = 'd'
+ )
+ and ag.group_key = :group_key
+ and grp.group_key = :group_key
+ and grp.adv_key = map.adv_key
+ and map.user_id = :user_id
+ and map.event_type = 'd'}]
- if {!$selection} {
+ if {!$selection} {
+ set adv_group_number 0
+ } else {
+ if {$adv_group_number == [expr $max_adv_group_number - 1]} {
set adv_group_number 0
- } else {
- if {$adv_group_number == [expr $max_adv_group_number - 1]} {
- set adv_group_number 0
- }
}
+ }
- set key [db_string adserver_sequential_get {
- select adv_key
- from adv_group_map
- where group_key=:group_key
- and adv_group_number=:adv_group_number} -default ""]
+ set key [db_string adserver_sequential_get {
+ select adv_key
+ from adv_group_map
+ where group_key=:group_key
+ and adv_group_number=:adv_group_number} -default ""]
- if {[string equal "" $key]} {
- set key [adserver_get_random_ad_key]
- }
+ if {[string equal "" $key]} {
+ set key [adserver_get_random_ad_key]
+ }
- return $key
+ return $key
}
############################################################
### helper functions to generate href and src attributes
############################################################
-### generate the href target
+### generate the href target
ad_proc -private adserver_href_attr {
-suppress_logging:boolean
{-adv_key ""}
target_url
- } {
- Returns href attribute.
+} {
+ Returns href attribute.
- } {
- set ad_url "[ad_acs_adserver_url]adhref?adv_key=[ad_urlencode $adv_key]"
- if {$suppress_logging_p == 1} {
- append ad_url "&suppress_logging_p=1"
- }
+} {
+ set ad_url "[ad_acs_adserver_url]adhref?adv_key=[ad_urlencode $adv_key]"
+ if {$suppress_logging_p == 1} {
+ append ad_url "&suppress_logging_p=1"
+ }
return $ad_url
}
@@ -439,16 +439,16 @@
ad_proc -private adserver_src_attr {
-suppress_logging:boolean
{-adv_key ""}
- } {
- Returns src attribute.
+} {
+ Returns src attribute.
Passes suppress_logging to adserver_image_url to build the url.
- } {
- set ad_url "[ad_acs_adserver_url]adimg?adv_key=[ad_urlencode $adv_key]"
- if {$suppress_logging_p == 1} {
- append ad_url "&suppress_logging_p=1"
- }
- return $ad_url
+} {
+ set ad_url "[ad_acs_adserver_url]adimg?adv_key=[ad_urlencode $adv_key]"
+ if {$suppress_logging_p == 1} {
+ append ad_url "&suppress_logging_p=1"
+ }
+ return $ad_url
}
###################################################################
@@ -458,7 +458,7 @@
### concatenate two pieces of a url. Gets number of /s right.
ad_proc -private adserver_url_concat {a b} {
joins a & b, ensuring that the right number of slashes are present
- } {
+} {
set as [string equal / [string range $a end end]]
set bs [string equal / [string range $b 0 0]]
if {$as && $bs} {
@@ -475,7 +475,7 @@
### generate the url for the image src attribute
ad_proc -private adserver_image_url {
ad_url
- } {
+} {
Builds the url to an image.
If local_image is true then this routine builds the url to a local
@@ -492,11 +492,11 @@
the return pathname can be returned using ns_returnfile AND not
ad_returnredirect
- } {
+} {
set image_path [util_memoize {
ad_parameter -package_id [ad_acs_adserver_id] \
- BaseImagePath adserver
+ BaseImagePath adserver
} [adserver_cache_refresh]]
# absolute or relative?
@@ -509,9 +509,15 @@
# local to the webserver
set url [adserver_url_concat \
- [adserver_url_concat \
- [ad_acs_adserver_pageroot] $image_path] \
- $ad_url]
+ [adserver_url_concat \
+ [ad_acs_adserver_pageroot] $image_path] \
+ $ad_url]
}
return $url
}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/adserver/www/adhref.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/adserver/www/adhref.tcl,v
diff -u -r1.4 -r1.5
--- openacs-4/packages/adserver/www/adhref.tcl 12 Feb 2019 18:00:04 -0000 1.4
+++ openacs-4/packages/adserver/www/adhref.tcl 12 Feb 2019 18:45:14 -0000 1.5
@@ -15,10 +15,10 @@
@cvs-id $Id$
} {
adv_key
- suppress_logging_p:optional
+ suppress_logging_p:optional
}
-# last edited November 24, 1999 to address a concurrency problem
+# last edited November 24, 1999 to address a concurrency problem
set adv_key [ns_urldecode $adv_key]
@@ -31,8 +31,8 @@
}
set target_url [db_string adv_url_query "
-select target_url
- from advs
+select target_url
+ from advs
where adv_key = :adv_key" -default ""]
if { $target_url == "" } {
@@ -41,7 +41,7 @@
} [adserver_cache_refresh]]
ad_returnredirect $target
ad_script_abort
-}
+}
ad_returnredirect $target_url
@@ -54,9 +54,9 @@
# we've returned to the user but let's keep this thread alive to log
set update_sql "
-update adv_log
- set click_count = click_count + 1
- where adv_key = :adv_key
+update adv_log
+ set click_count = click_count + 1
+ where adv_key = :adv_key
and entry_date = trunc (sysdate)
"
@@ -65,21 +65,21 @@
set n_rows [db_resultrows]
if { $n_rows == 0 } {
-
+
# there wasn't already a row there let's be careful in case
# another thread is executing concurrently on the 10000:1 chance
# that it is, we might lose an update but we won't generate an
# error in the error log and set off all the server monitor alarms
-
+
set insert_sql "
insert into adv_log
(adv_key, entry_date, click_count)
values (:adv_key,
trunc (sysdate),
- (select 1 from dual
- where 0 = (select count (*)
- from adv_log
- where adv_key = :adv_key
+ (select 1 from dual
+ where 0 = (select count (*)
+ from adv_log
+ where adv_key = :adv_key
and entry_date = trunc (sysdate))))"
db_dml adv_insert $insert_sql
}
@@ -90,11 +90,16 @@
set user_id [ad_get_user_id]
if { $user_id == 0 } {
set user_id ""
- }
+ }
# we know who this user is
db_dml adv_known_user_insert "
- insert into adv_user_map (user_id, adv_key, event_time, event_type)
+ insert into adv_user_map (user_id, adv_key, event_time, event_type)
values (:user_id, :adv_key, sysdate, 'c')
"
}
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/adserver/www/adimg.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/adserver/www/adimg.tcl,v
diff -u -r1.4 -r1.5
--- openacs-4/packages/adserver/www/adimg.tcl 12 Feb 2019 18:00:04 -0000 1.4
+++ openacs-4/packages/adserver/www/adimg.tcl 12 Feb 2019 18:45:14 -0000 1.5
@@ -4,7 +4,7 @@
This page tries to find an image file to serve to the user,
serves it, closes the TCP connection to the user.
while this thread is still alive, logs the ad display
-
+
@author philg@mit.edu
@author jerry@hollyjerry.org
@creation-date 11/24/1999
@@ -14,7 +14,7 @@
suppress_logging_p:optional
}
-# last edited November 24, 1999 to address a concurrency problem
+# last edited November 24, 1999 to address a concurrency problem
set display_default_banner_p 0
@@ -30,13 +30,13 @@
} [adserver_cache_refresh]]
} else {
if { [db_0or1row adv_select "
- SELECT adv_filename as ad_filename_stub,
+ SELECT adv_filename as ad_filename_stub,
decode(local_image_p, 't', 1, 0) as local_image
FROM advs
WHERE adv_key = :adv_key"] } {
# correct vars set
} else {
- set display_default_banner_p 1
+ set display_default_banner_p 1
}
}
@@ -48,7 +48,7 @@
ns_log Error "Didn't find ad: $ad_filename"
if {$display_default_banner_p == 1} {
- # we're really in bad shape; no row exists and
+ # we're really in bad shape; no row exists and
# we don't have an adv_key
ns_log Error "adimg.tcl didn't find an ad matching " \
"\"$adv_key\" AND no default file exists"
@@ -94,9 +94,9 @@
if {$display_default_banner_p == 0} {
db_dml adv_log_update_query "
- update adv_log
- set display_count = display_count + 1
- where adv_key = :adv_key
+ update adv_log
+ set display_count = display_count + 1
+ where adv_key = :adv_key
and entry_date = current_date"
set n_rows [db_resultrows]
@@ -105,14 +105,14 @@
# there wasn't a row in the database; we can't just do the obvious
# insert because another thread might be executing concurrently
db_dml adv_insert "
- insert into adv_log
- (adv_key, entry_date, display_count)
+ insert into adv_log
+ (adv_key, entry_date, display_count)
values (:adv_key,
current_date,
- (select 1 from dual
- where 0 = (select count (*)
- from adv_log
- where adv_key = :adv_key
+ (select 1 from dual
+ where 0 = (select count (*)
+ from adv_log
+ where adv_key = :adv_key
and entry_date = current_date)))"
}
@@ -122,11 +122,16 @@
set user_id [ad_get_user_id]
if { $user_id == 0 } {
set user_id ""
- }
+ }
# we know who this user is
db_dml adv_known_user_insert "
- insert into adv_user_map (user_id, adv_key, event_time, event_type)
+ insert into adv_user_map (user_id, adv_key, event_time, event_type)
values (:user_id, :adv_key, sysdate, 'd')"
}
}
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/download/tcl/download-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/download/tcl/download-procs.tcl,v
diff -u -r1.20 -r1.21
--- openacs-4/packages/download/tcl/download-procs.tcl 12 Feb 2019 18:00:04 -0000 1.20
+++ openacs-4/packages/download/tcl/download-procs.tcl 12 Feb 2019 18:45:14 -0000 1.21
@@ -74,10 +74,10 @@
}
"text" {
- append html "<textarea name=$element_name cols=70 rows=10>$user_value</textarea>"
+ append html "<textarea name=$element_name cols=70 rows=10>$user_value</textarea>"
}
"date" {
- append html "[ad_dateentrywidget $element_name $user_value]"
+ append html "[ad_dateentrywidget $element_name $user_value]"
}
"boolean" {
append html "<select name=$element_name>
@@ -111,10 +111,10 @@
ad_proc download_file_downloader {
} {
- Sends the requested file to the user. Note that the path has the
- original file name, so the browser will have a sensible name if you
+ Sends the requested file to the user. Note that the path has the
+ original file name, so the browser will have a sensible name if you
save the file. Version downloads are supported by looking for
- the form variable version_id. We don't actually check that the
+ the form variable version_id. We don't actually check that the
version_id matches the path, we just serve it up.
} {
ad_page_contract {
@@ -124,7 +124,7 @@
{ reason_id "" }
{ reason_other ""}
}
-
+
ns_log Debug "download_file_downloader: downloading $revision_id"
set user_id [ad_conn user_id]
@@ -150,20 +150,20 @@
if {[catch {
db_dml download_insert {
insert into download_downloads (
- download_id,
- user_id,
- revision_id,
- download_date,
+ download_id,
+ user_id,
+ revision_id,
+ download_date,
download_ip,
download_hostname,
user_agent,
reason_id,
reason)
values
- (:download_id,
- :user_id,
- :revision_id,
- sysdate,
+ (:download_id,
+ :user_id,
+ :revision_id,
+ sysdate,
:download_ip,
:download_hostname,
:user_agent,
@@ -207,7 +207,7 @@
set metadata_with_missing_responses [list]
##Iterate over the metadata information
db_foreach metadata {
- select
+ select
dam.metadata_id,
dam.pretty_name,
dam.data_type,
@@ -250,10 +250,10 @@
ad_complain "The value for \"$metadata\" must be an integer. Your value was \"$response_value\"."
continue
}
- }
+ }
}
-
+
ns_log Debug "LOGGING: Metadata $pretty_name: $metadata($metadata_id)"
}
if { [llength $metadata_with_missing_responses] > 0 } {
@@ -270,7 +270,7 @@
} {
array set metadata $metadata_array
set metadata_list [db_list_of_lists survsimp_question_info_list {
- select
+ select
dam.metadata_id,
dam.data_type
from download_archive_metadata dam
@@ -282,8 +282,8 @@
}]
foreach metadata_info $metadata_list {
- set metadata_id [lindex $metadata_info 0]
- set data_type [lindex $metadata_info 1]
+ set metadata_id [lindex $metadata_info 0]
+ set data_type [lindex $metadata_info 1]
set response $metadata($metadata_id)
set answer_column [download_metadata_column $data_type]
db_dml metadata_inserts "
@@ -350,4 +350,3 @@
# tcl-indent-level: 4
# indent-tabs-mode: nil
# End:
-
Index: openacs-4/packages/download/www/archive-add-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/download/www/archive-add-2.tcl,v
diff -u -r1.10 -r1.11
--- openacs-4/packages/download/www/archive-add-2.tcl 12 Feb 2019 18:00:04 -0000 1.10
+++ openacs-4/packages/download/www/archive-add-2.tcl 12 Feb 2019 18:45:14 -0000 1.11
@@ -89,10 +89,16 @@
}
download_insert_revision $upload_file ${upload_file.tmpfile} $repository_id \
- $archive_type_id $archive_id $version_name $revision_id \
- $user_id $creation_ip $approved_p [array get metadata]
+ $archive_type_id $archive_id $version_name $revision_id \
+ $user_id $creation_ip $approved_p [array get metadata]
}
ad_returnredirect $return_url
ad_script_abort
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/download/www/archive-version-add-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/download/www/archive-version-add-2.tcl,v
diff -u -r1.5 -r1.6
--- openacs-4/packages/download/www/archive-version-add-2.tcl 12 Feb 2019 18:00:04 -0000 1.5
+++ openacs-4/packages/download/www/archive-version-add-2.tcl 12 Feb 2019 18:45:14 -0000 1.6
@@ -44,3 +44,9 @@
}
ad_returnredirect $return_url
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/download/www/admin/approve-or-reject-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/download/www/admin/approve-or-reject-2.tcl,v
diff -u -r1.11 -r1.12
--- openacs-4/packages/download/www/admin/approve-or-reject-2.tcl 12 Feb 2019 18:00:04 -0000 1.11
+++ openacs-4/packages/download/www/admin/approve-or-reject-2.tcl 12 Feb 2019 18:45:14 -0000 1.12
@@ -1,6 +1,6 @@
# /packages/download/www/admin/approve-or-reject-2.tcl
ad_page_contract {
-
+
@author jbank@arsdigita.com [jbank@arsdigita.com]
@creation-date Wed Dec 13 10:10:30 2000
@cvs-id $Id$
@@ -43,7 +43,7 @@
approved_user = :user_id,
approved_date = sysdate
where revision_id = :revision_id
- "
+ "
} errmsg]} {
ad_return_error "Problem $approval_action version" "There was a problem $approval_action the version
in the database. Here's the error message: $errmsg"
@@ -57,18 +57,18 @@
if {[parameter::get -package_id [ad_conn package_id] -parameter approval_notification -default 1] == 1} {
# We want to send email to use who submitted the version to let
# them know it's approved (or rejected).
-
+
# This is the email address of the user who submitted the version.
- db_1row creation_email_select { *SQL* }
+ db_1row creation_email_select { *SQL* }
# This is the email address and name of the user who approved (or rejected) the version
db_1row approving_user_select { *SQL* }
set body "
Your posting to [ad_system_name] $repository_info(title): $archive_name $version_name
-
+
[ad_url][ad_conn package_url]/one-revision?revision_id=$revision_id
-
+
was approved by $approving_name:\n\n$approved_comment"
set subject "$repository_info(title): $archive_name $version_name $approval_status: "
@@ -77,3 +77,9 @@
-subject $subject -body $body
}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/dynamic-types/tcl/dynamic-type-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/dynamic-types/tcl/dynamic-type-procs.tcl,v
diff -u -r1.13 -r1.14
--- openacs-4/packages/dynamic-types/tcl/dynamic-type-procs.tcl 12 Feb 2019 18:00:04 -0000 1.13
+++ openacs-4/packages/dynamic-types/tcl/dynamic-type-procs.tcl 12 Feb 2019 18:45:14 -0000 1.14
@@ -2,11 +2,11 @@
A library of functions to create and manipulate dynamic object types.
Creating a type through this api ensures that the necessary datamodel is in
- place for the type and that a subtype of acs_object and corresponding
- acs_attribute metadata has been recorded.
+ place for the type and that a subtype of acs_object and corresponding
+ acs_attribute metadata has been recorded.
Currently (2004/10/12) only 'type_specific' attribute storage is supported,
- although the API could be extended to support 'generic' skinny table
+ although the API could be extended to support 'generic' skinny table
storage.
Special code handles subtypes of 'content_revision' so that dynamic content
@@ -15,7 +15,7 @@
@author Rob Denison (rob@xarg.net)
@creation-date 2004/10/12
@cvs-id $Id$
-}
+}
namespace eval dtype {}
@@ -36,36 +36,36 @@
foreach attribute_info $attributes_list {
foreach {name pretty_name attribute_id datatype table_name column_name default_value min_n_values max_n_values static_p} $attribute_info break
- if {$column_name == "package_id"} {
- continue
- }
+ if {$column_name == "package_id"} {
+ continue
+ }
switch $datatype {
- date -
- timestamp -
- time_of_day {
- set format "'YYYY-MM-DD HH24:MI:SS'"
- lappend columns "to_char($column_name, $format) as $name"
- }
- boolean {
- lappend columns "case when $column_name = true then 't' else 'f' end as $name"
- }
- default {
- lappend columns "$column_name as $name"
- }
+ date -
+ timestamp -
+ time_of_day {
+ set format "'YYYY-MM-DD HH24:MI:SS'"
+ lappend columns "to_char($column_name, $format) as $name"
+ }
+ boolean {
+ lappend columns "case when $column_name = true then 't' else 'f' end as $name"
+ }
+ default {
+ lappend columns "$column_name as $name"
+ }
}
}
if {[llength $columns] > 0} {
- db_1row select_table_name {}
- set columns [join $columns ", "]
- db_0or1row select_object {} -column_array data
+ db_1row select_table_name {}
+ set columns [join $columns ", "]
+ db_0or1row select_object {} -column_array data
}
dtype::form::metadata::widgets -object_type $object_type \
-dform $dform \
- -exclude_static_p $exclude_static_p \
+ -exclude_static_p $exclude_static_p \
-multirow widgets
-
+
dtype::form::metadata::params -object_type $object_type \
-dform $dform \
-multirow params
@@ -76,28 +76,28 @@
for {set w 1} {$w <= $widget_count} {incr w} {
template::multirow get widgets $w
- if {$dform != "implicit" && ([lsearch -exact [list "select" "multiselect" "checkbox" "radio"] $widgets(widget)] > -1)} {
+ if {$dform != "implicit" && ([lsearch -exact [list "select" "multiselect" "checkbox" "radio"] $widgets(widget)] > -1)} {
- for {set p 1} {$p <= $param_count} {incr p} {
- template::multirow get params $p
+ for {set p 1} {$p <= $param_count} {incr p} {
+ template::multirow get params $p
- if {$params(attribute_id) != $widgets(attribute_id) || $params(param) != "options"} {
- continue;
- }
+ if {$params(attribute_id) != $widgets(attribute_id) || $params(param) != "options"} {
+ continue;
+ }
- set options [lang::util::localize [dtype::form::parameter_value -parameter params -vars $variables]]
- set new_value ""
- set old_value $data($widgets(attribute_name))
- foreach option $options {
- if {[lsearch -exact $old_value [lindex $option 1]] > -1} {
- lappend new_value [lindex $option 0]
- }
- }
- set local($widgets(attribute_name)) [join $new_value ", "]
- }
- } else {
- set local($widgets(attribute_name)) $data($widgets(attribute_name))
- }
+ set options [lang::util::localize [dtype::form::parameter_value -parameter params -vars $variables]]
+ set new_value ""
+ set old_value $data($widgets(attribute_name))
+ foreach option $options {
+ if {[lsearch -exact $old_value [lindex $option 1]] > -1} {
+ lappend new_value [lindex $option 0]
+ }
+ }
+ set local($widgets(attribute_name)) [join $new_value ", "]
+ }
+ } else {
+ set local($widgets(attribute_name)) $data($widgets(attribute_name))
+ }
}
}
@@ -110,7 +110,7 @@
{-id_column "XXX"}
{-name_method ""}
} {
- Creates a content type with consolidated view (see plpgsql function
+ Creates a content type with consolidated view (see plpgsql function
dynamic_type__create_type).
} {
ns_log Debug "DYNAMIC TYPES: Creating Object $name with Pretty Name $pretty_name"
@@ -163,7 +163,7 @@
set event(attribute) $name
set event(action) created
util::event::fire -event dtype.attribute event
-
+
if {!$no_flush_p} {
dtype::flush_cache -type $name -event event
}
@@ -187,7 +187,7 @@
-storage_types $storage_types]
if {!$list} {
-
+
template::multirow create $multirow \
name \
pretty_name \
@@ -200,7 +200,7 @@
max_n_values \
storage \
static_p
-
+
foreach attribute $attributes {
template::multirow append $multirow \
[lindex $attribute 0] \
@@ -217,7 +217,7 @@
}
} else {
return $attributes
- }
+ }
}
ad_proc -private dtype::get_attributes_list {
@@ -227,16 +227,16 @@
{-storage_types:required}
{-exclude_static_p 0}
} {
- Gets all the attributes of a object_type.
+ Gets all the attributes of a object_type.
} {
if {$no_cache_p} {
set storage_clause "and a.storage in ('[join $storage_types "', '"]')"
- if {$exclude_static_p} {
- return [db_list_of_lists select_attributes_dynamic {}]
- } else {
- return [db_list_of_lists select_attributes {}]
- }
+ if {$exclude_static_p} {
+ return [db_list_of_lists select_attributes_dynamic {}]
+ } else {
+ return [db_list_of_lists select_attributes {}]
+ }
} else {
return [util_memoize "dtype::get_attributes_list -no_cache -name \"$name\" -start_with \"$start_with\" -storage_types \"$storage_types\" -exclude_static_p $exclude_static_p"]
}
@@ -247,7 +247,7 @@
{-event:required}
} {
Flushes the util_memoize cache of dtype calls for a given object type.
-
+
event is assumed to be a name of an array that contains object_type and action
} {
upvar $event dtype_event
@@ -337,7 +337,7 @@
set pretty_plural $pretty_name
# FIXME do we want a default name method?
set name_method ""
-
+
set code {}
append code "
dtype::create \
@@ -386,7 +386,7 @@
"
}
}
-
+
return $code
}
@@ -400,10 +400,10 @@
} {
Create a dynamic types form for object type based on type
definition using intelligent defaults.
-
+
@author Dave Bauer (dave@thedesignexperience.org)
@creation-date 2005-02-14
-
+
@param object_type Object type form is for
@param dform Name of form. We can't use 'default' because that is
@@ -415,11 +415,11 @@
instead of calling dtype::form::generate_widget repeatedly
@param evaluate T or F, whether to evalute the code or just
- return it
+ return it
@return If evaluate is false, return code generated.
-
- @error
+
+ @error
} {
set code ""
# get widget defaults
@@ -429,19 +429,19 @@
-object_id "" \
-object_type $object_type]
set object_type [lindex $types 0]
-
+
array set type_dforms $dforms
# FIXME use spec if available!
-
+
# get default widgets
foreach type $types {
- if {[info exists type_dforms($type)]} {
- set type_dform $type_dforms($type)
- } else {
- set type_dform "implicit"
- }
-
+ if {[info exists type_dforms($type)]} {
+ set type_dform $type_dforms($type)
+ } else {
+ set type_dform "implicit"
+ }
+
dtype::form::metadata::widgets -object_type $type \
-dform $type_dform \
-multirow widgets
@@ -470,7 +470,7 @@
# if type of the foreign key table is a subtype of
# content revision, use the i view
# also check if its a dtype
-
+
append code "
dtype::form::metadata::create_widget_param \
-object_type $object_type \
@@ -485,7 +485,7 @@
}
-
+
}
}
if {$evaluate} {
@@ -498,36 +498,41 @@
ad_proc -public dtype::get_table_name {
-object_type
} {
-
+
Get name of type specicifc storage table
-
+
@author Dave Bauer (dave@thedesignexperience.org)
@creation-date 2005-02-14
-
+
@param object_type Object type
@return Table Name
-
- @error
+
+ @error
} {
return [db_string get_table_name "" -default ""]
}
ad_proc -public dtype::get_id_column {
-object_type
} {
-
+
Get name of type specicifc storage table
-
+
@author Dave Bauer (dave@thedesignexperience.org)
@creation-date 2005-02-14
-
+
@param object_type Object type
@return Table Name
-
- @error
+
+ @error
} {
return [db_string get_id_column "" -default ""]
}
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/dynamic-types/tcl/form-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/dynamic-types/tcl/form-procs.tcl,v
diff -u -r1.20 -r1.21
--- openacs-4/packages/dynamic-types/tcl/form-procs.tcl 12 Feb 2019 18:00:04 -0000 1.20
+++ openacs-4/packages/dynamic-types/tcl/form-procs.tcl 12 Feb 2019 18:45:14 -0000 1.21
@@ -1,28 +1,27 @@
-
ad_library {
- A library of functions to generate forms for acs_objects from stored
+ A library of functions to generate forms for acs_objects from stored
metadata.
-
- The API manipulates two concepts - forms and widgets. Forms are
- mapped to object_types. Each object_type can have several named forms
- mapped to it and is always mapped to a form called 'implicit'. Each
- form is mapped to several widgets which correspond to the attributes
- of its object_type.
- It's possible for example to create two forms 'admin' and 'public'.
- The public form could contain widgets for the attributes that may be
- modified by public users whereas the admin form could contain
+ The API manipulates two concepts - forms and widgets. Forms are
+ mapped to object_types. Each object_type can have several named forms
+ mapped to it and is always mapped to a form called 'implicit'. Each
+ form is mapped to several widgets which correspond to the attributes
+ of its object_type.
+
+ It's possible for example to create two forms 'admin' and 'public'.
+ The public form could contain widgets for the attributes that may be
+ modified by public users whereas the admin form could contain
additional elements that admin users can edit.
The implicit form always contains widgets for all attributes in a type.
- Widgets have associated parameters which control how the html
+ Widgets have associated parameters which control how the html
representation is displayed, how values and options are retrieved and
how submitted values are validated. Each widget has a default value
for supported parameters. Additional default parameter values come in
- to play when a widget is combined a datatype - for example, the
- default options for a radio widget used for a boolean datatype are
- 'Yes' and 'No'. Any parameter can, and often should, be overridden
+ to play when a widget is combined a datatype - for example, the
+ default options for a radio widget used for a boolean datatype are
+ 'Yes' and 'No'. Any parameter can, and often should, be overridden
for non-implicit forms.
}
@@ -50,32 +49,32 @@
supertypes dynamic forms to the specified template form.
This function is used for both add and edit forms. It determines which is
- appropriate based on whether an object_id or an object_type is supplied.
+ appropriate based on whether an object_id or an object_type is supplied.
Only one of object_type or object_id may be supplied.
@param object_id the object represented in the form. If set the form is
assumed to be an edit form, otherwise it is assumed to be an object
create form
@param object_type the object type whose metadata will define the form
@param dform specifies the stored object form to use
- @param dforms specifies the stored object form to use for particular object
+ @param dforms specifies the stored object form to use for particular object
types - used to override the dform parameter
- @param form the name of the template::form to add the elements to (will
+ @param form the name of the template::form to add the elements to (will
create the form if it doesn't already exist)
@param prefix prefix for each attribute name to avoid collisions
@param section form section that the elements should be added to
@param overrides key value pairs that will override the initial value of
- a form element irrespective of the default value in the form
+ a form element irrespective of the default value in the form
metadata of the value in the object being edited
- @param content_widget the widget to use for the content when the
+ @param content_widget the widget to use for the content when the
object_type is a subtype of content_revision
} {
if {![template::form exists $form]} {
template::form create $form
}
if {![empty_string_p $object_id]} {
- set object_id [db_string check_object_existence {} -default ""]
+ set object_id [db_string check_object_existence {} -default ""]
}
set types [dtype::form::types_list \
@@ -97,11 +96,11 @@
}
if {!$no_action_p} {
- template::element create $form ${prefix}dform_action \
- -widget hidden \
- -datatype text \
- -sign \
- -value $action
+ template::element create $form ${prefix}dform_action \
+ -widget hidden \
+ -datatype text \
+ -sign \
+ -value $action
}
foreach type $types {
@@ -111,11 +110,11 @@
set type_dform $dform
}
- if {$action != "new"} {
- dtype::get_object -object_id $object_id \
- -object_type $object_type \
- -array object
- }
+ if {$action != "new"} {
+ dtype::get_object -object_id $object_id \
+ -object_type $object_type \
+ -array object
+ }
set object(object_id) $object_id
dtype::form::add_type_elements -object_array object \
@@ -127,9 +126,9 @@
-overrides [array get override] \
-cr_widget $cr_widget \
-cr_widget_options $cr_widget_options \
- -exclude_static_p $exclude_static_p \
- -exclude $exclude \
- -variables $variables
+ -exclude_static_p $exclude_static_p \
+ -exclude $exclude \
+ -variables $variables
}
}
@@ -150,21 +149,21 @@
{-dont_publish:boolean}
} {
Process a dynamic type form submission created by a function such as
- dtype::form::add_elements.
+ dtype::form::add_elements.
@param object_type the object type whose metadata will define the form
@param dform specifies the stored object form used
- @param dforms specifies the stored object form to use for particular object
+ @param dforms specifies the stored object form to use for particular object
types - used to override the dform parameter
@param form the name of the template::form used
@param prefix the prefix for each attribute name used
@param defaults default values to use for attributes (this should be used
to supply values for context_id and the like)
@param default_fields default columns with values to be used for db insert
- @param cr_widget the input method for the content
+ @param cr_widget the input method for the content
@param cr_storage the content repository storage method
@param dont_publish prevents from setting the live_revisions
-
+
<p>TODO: Add support for HTMLArea.</p>
@see dtype::form::add_elements
@@ -173,7 +172,7 @@
# could be created that doesn't include object_id as a field in which
# case this would just break.
if {[empty_string_p $object_id]} {
- set object_id [template::element::get_value $form ${prefix}object_id]
+ set object_id [template::element::get_value $form ${prefix}object_id]
}
# Pull the action out of the form
@@ -200,37 +199,37 @@
#
set default(object_type) $object_type
if {![info exists default(creation_user)]} {
- set default(creation_user) [ad_conn user_id]
+ set default(creation_user) [ad_conn user_id]
}
if {![info exists default(creation_ip)]} {
- set default(creation_ip) [ad_conn peeraddr]
+ set default(creation_ip) [ad_conn peeraddr]
}
if {![info exists default(context_id)]} {
- set default(context_id) ""
+ set default(context_id) ""
}
if {![info exists default(package_id)]} {
- set default(package_id) [ad_conn package_id]
+ set default(package_id) [ad_conn package_id]
}
if {![info exists default(parent_id)]} {
- set default(parent_id) ""
+ set default(parent_id) ""
}
if {![info exists default(nls_language)]} {
- set default(nls_language) ""
+ set default(nls_language) ""
}
if {![info exists default(publish_date)]} {
- set default(publish_date) ""
+ set default(publish_date) ""
}
-
+
#######################################################
# Content Repository specific preparations
#
if {$content_type_p} {
- if {![info exists default(mime_type)]} {
- set default(mime_type) "text/plain"
- }
+ if {![info exists default(mime_type)]} {
+ set default(mime_type) "text/plain"
+ }
if {$new_p} {
- # We are creating an initial revision of a content item (ie. a new
- # instance of a subtype of content_revision). We need to first
+ # We are creating an initial revision of a content item (ie. a new
+ # instance of a subtype of content_revision). We need to first
# create a content_item object.
set item_id [db_nextval acs_object_id_seq]
@@ -244,7 +243,7 @@
creation_user [ad_conn user_id] \
creation_ip [ad_conn peeraddr] \
storage_type $cr_storage]
-
+
foreach var [array names item_defaults] {
if {[info exists default($var)]} {
set item_$var $default($var)
@@ -259,7 +258,7 @@
db_exec_plsql create_item {}
} else {
# We are adding a revision to an existing content type - we ignore
- # any passed in storage type and use the one set in the content
+ # any passed in storage type and use the one set in the content
# item
set item_id [item::get_item_from_revision $object_id]
content::item::get -item_id $item_id -array item
@@ -273,7 +272,7 @@
set tmp_file [ns_queryget ${prefix}content.tmpfile]
set default(filename) ""
- # Make sure we have a file to upload the content from in utf-8
+ # Make sure we have a file to upload the content from in utf-8
# encoding
if {![string equal $cr_widget file]} {
set tmp_file [dtype::write_utf8_file $content]
@@ -296,29 +295,29 @@
# set default fields with provided values
foreach var_spec $default_fields {
- set var_name [lindex $var_spec 0]
- if {[llength $var_spec] > 1} {
- set var_value [uplevel subst \{[lindex $var_spec 1]\}]
- } else {
- upvar 1 $var_name upvar_variable
- if {[info exists upvar_variable]} {
- set crvd_$var_name $upvar_variable
- set var_value ":crvd_$var_name"
- } else {
- set var_value "null"
- }
- }
- lappend columns $var_name
- lappend values $var_value
+ set var_name [lindex $var_spec 0]
+ if {[llength $var_spec] > 1} {
+ set var_value [uplevel subst \{[lindex $var_spec 1]\}]
+ } else {
+ upvar 1 $var_name upvar_variable
+ if {[info exists upvar_variable]} {
+ set crvd_$var_name $upvar_variable
+ set var_value ":crvd_$var_name"
+ } else {
+ set var_value "null"
+ }
+ }
+ lappend columns $var_name
+ lappend values $var_value
}
# LEED context_id and similar fields should be passed in using the
# -defaults { context_id 1234 } argument
-
+
foreach type $types {
set missing_columns ""
- # Add attributes to $columns and associated bind variables to $values
+ # Add attributes to $columns and associated bind variables to $values
# for each type
if {[info exists type_dforms($type)]} {
set type_dform $type_dforms($type)
@@ -333,19 +332,19 @@
dtype::form::metadata::widgets -object_type $type \
-dform $type_dform \
- -exclude_static_p $exclude_static_p \
+ -exclude_static_p $exclude_static_p \
-indexed_array widgets
set size [template::multirow size attributes]
for {set i 1} {$i <= $size} {incr i} {
template::multirow get attributes $i
-
- # exclude specified widgets
+
+ # exclude specified widgets
if {[lsearch -exact $exclude $attributes(name)] > -1} {
- continue
- }
+ continue
+ }
- set crv_$attributes(name) ""
+ set crv_$attributes(name) ""
ns_log debug "PROCESSING: $attributes(name)"
if {[info exists widgets($attributes(attribute_id))]} {
@@ -354,7 +353,7 @@
array set this_widget_info $widgets($attributes(attribute_id))
switch $this_widget_info(widget) {
file {}
- checkbox - multiselect {
+ checkbox - multiselect {
set crv_$attributes(name) [template::element::get_values $form ${prefix}$attributes(name)]
}
default {
@@ -366,41 +365,41 @@
if {[empty_string_p [set crv_$attributes(name)]]} {
# second check if the caller supplied a default value
set crv_$attributes(name) $default($attributes(name))
- }
+ }
- } elseif {$new_p && ![empty_string_p $attributes(default_value)]} {
- ns_log debug "PROCESSING: using attribute default for $attributes(name)"
+ } elseif {$new_p && ![empty_string_p $attributes(default_value)]} {
+ ns_log debug "PROCESSING: using attribute default for $attributes(name)"
- # if we are inserting a new object then use the attributes
- # default value
- set crv_$attributes(name) $attributes(default_value)
+ # if we are inserting a new object then use the attributes
+ # default value
+ set crv_$attributes(name) $attributes(default_value)
- } elseif {!$new_p} {
- ns_log debug "PROCESSING: using existing value for $attributes(name) (ie. adding it to missing columns)"
+ } elseif {!$new_p} {
+ ns_log debug "PROCESSING: using existing value for $attributes(name) (ie. adding it to missing columns)"
- # append the column to missing columns so that the value
- # is copied from the previous revision when we are dealing
- # with content types
- if {[lsearch -exact {creation_date last_modified modifying_ip} $attributes(name)] == -1} {
- lappend missing_columns $attributes(column_name)
- }
- }
+ # append the column to missing columns so that the value
+ # is copied from the previous revision when we are dealing
+ # with content types
+ if {[lsearch -exact {creation_date last_modified modifying_ip} $attributes(name)] == -1} {
+ lappend missing_columns $attributes(column_name)
+ }
+ }
- if {![empty_string_p [set crv_$attributes(name)]] && [lsearch -exact $columns $attributes(name)] == -1} {
- lappend columns $attributes(column_name)
+ if {![empty_string_p [set crv_$attributes(name)]] && [lsearch -exact $columns $attributes(name)] == -1} {
+ lappend columns $attributes(column_name)
- # cast the value to the appropriate datatype
- switch $attributes(datatype) {
- date - time_of_day - timestamp {
- lappend values [template::util::date::get_property sql_date [lindex [set crv_$attributes(name)] 0]]
- }
- boolean {
- lappend values [ad_decode [set crv_$attributes(name)] t true false]
- }
- default {
- lappend values ":crv_$attributes(name)"
- }
- }
+ # cast the value to the appropriate datatype
+ switch $attributes(datatype) {
+ date - time_of_day - timestamp {
+ lappend values [template::util::date::get_property sql_date [lindex [set crv_$attributes(name)] 0]]
+ }
+ boolean {
+ lappend values [ad_decode [set crv_$attributes(name)] t true false]
+ }
+ default {
+ lappend values ":crv_$attributes(name)"
+ }
+ }
}
}
}
@@ -410,91 +409,91 @@
#
# the postgres "insert into view" is rewritten by the rule into a "select", so no dml..
- set db_stmt [expr {[db_driverkey ""] eq "postgresql" ? "db_0or1row" : "db_dml"}]
+ set db_stmt [expr {[db_driverkey ""] eq "postgresql" ? "db_0or1row" : "db_dml"}]
# title, description, object_title
if {$content_type_p} {
- set pos [lsearch -exact $columns package_id]
- set columns [lreplace $columns $pos $pos object_package_id]
- set columns [concat "item_id" "revision_id" $columns]
- set values [concat ":item_id" ":object_id" $values]
+ set pos [lsearch -exact $columns package_id]
+ set columns [lreplace $columns $pos $pos object_package_id]
+ set columns [concat "item_id" "revision_id" $columns]
+ set values [concat ":item_id" ":object_id" $values]
- # Make sure not to set the object_package_id as this does not work
- # More important though: The content_revision__new function automatically
- # detects the package_id of the item.
+ # Make sure not to set the object_package_id as this does not work
+ # More important though: The content_revision__new function automatically
+ # detects the package_id of the item.
- # Ideally someone would get rid of object_package_id and :crv_package_id
- # in columns and values. MS 2006/08/07
- set crv_package_id ""
+ # Ideally someone would get rid of object_package_id and :crv_package_id
+ # in columns and values. MS 2006/08/07
+ set crv_package_id ""
- db_transaction {
- if {$new_p} {
- $db_stmt insert_statement "
- insert into ${type_info(table_name)}i
- ([join $columns ", "])
- values
- ([join $values ", "])"
- } else {
- set latest_revision [content::item::get_latest_revision -item_id $item_id]
- set object_id [db_nextval acs_object_id_seq]
+ db_transaction {
+ if {$new_p} {
+ $db_stmt insert_statement "
+ insert into ${type_info(table_name)}i
+ ([join $columns ", "])
+ values
+ ([join $values ", "])"
+ } else {
+ set latest_revision [content::item::get_latest_revision -item_id $item_id]
+ set object_id [db_nextval acs_object_id_seq]
- $db_stmt insert_statement "
- insert into ${type_info(table_name)}i
- ([join [concat $columns $missing_columns] ", "])
- select
- [join [concat $values $missing_columns] ", "]
- from ${type_info(table_name)}i
- where revision_id = $latest_revision"
- }
+ $db_stmt insert_statement "
+ insert into ${type_info(table_name)}i
+ ([join [concat $columns $missing_columns] ", "])
+ select
+ [join [concat $values $missing_columns] ", "]
+ from ${type_info(table_name)}i
+ where revision_id = $latest_revision"
+ }
- if {!$dont_publish_p} {
- content::item::set_live_revision -revision_id $object_id
- }
+ if {!$dont_publish_p} {
+ content::item::set_live_revision -revision_id $object_id
+ }
- set revision_ids [db_list get_revision_ids {}]
- set revision_id [lindex $revision_ids 0]
- set prev_revision_id [lindex $revision_ids 1]
+ set revision_ids [db_list get_revision_ids {}]
+ set revision_id [lindex $revision_ids 0]
+ set prev_revision_id [lindex $revision_ids 1]
- if {[string equal $cr_widget none] ||
- ([string equal $cr_widget file] &&
- [string equal $tmp_file ""])} {
+ if {[string equal $cr_widget none] ||
+ ([string equal $cr_widget file] &&
+ [string equal $tmp_file ""])} {
- # either a content widget wasn't included in the form or
- # no new file was uploaded, so we want to preserve the previous
- # revisions content
- if {![string equal $prev_revision_id ""]} {
- db_dml update_content {}
- }
- } else {
- dtype::upload_content -item_id $item_id \
- -revision_id $revision_id \
- -file $tmp_file \
- -storage_type $cr_storage
+ # either a content widget wasn't included in the form or
+ # no new file was uploaded, so we want to preserve the previous
+ # revisions content
+ if {![string equal $prev_revision_id ""]} {
+ db_dml update_content {}
+ }
+ } else {
+ dtype::upload_content -item_id $item_id \
+ -revision_id $revision_id \
+ -file $tmp_file \
+ -storage_type $cr_storage
- ns_unlink $tmp_file
- }
- }
+ ns_unlink $tmp_file
+ }
+ }
} else {
- if {$new_p} {
- $db_stmt insert_statement "
- insert into ${type_info(table_name)}i ([join $columns ", "])
- values ([join $values ", "])"
- } else {
- set updates [list]
+ if {$new_p} {
+ $db_stmt insert_statement "
+ insert into ${type_info(table_name)}i ([join $columns ", "])
+ values ([join $values ", "])"
+ } else {
+ set updates [list]
- set all_columns [concat $columns $missing_columns]
- set all_values [concat $values $missing_columns]
+ set all_columns [concat $columns $missing_columns]
+ set all_values [concat $values $missing_columns]
- set length [llength $all_columns]
- for {set i 0} {$i < $length} {incr i} {
- lappend updates "[lindex $all_columns $i] = [lindex $all_values $i]"
- }
+ set length [llength $all_columns]
+ for {set i 0} {$i < $length} {incr i} {
+ lappend updates "[lindex $all_columns $i] = [lindex $all_values $i]"
+ }
- db_dml update_statement "
- update ${type_info(table_name)}i
- set [join $updates ", "]
- where $type_info(id_column) = :object_id"
- }
+ db_dml update_statement "
+ update ${type_info(table_name)}i
+ set [join $updates ", "]
+ where $type_info(id_column) = :object_id"
+ }
}
return $object_id
@@ -515,7 +514,7 @@
{-variables {}}
} {
Adds the elements of the specified or implicit object form to the specified
- template form.
+ template form.
@param object_array the object for the form (not set for object creation)
@param object_type the object type whose metadata will define the form
@@ -534,13 +533,13 @@
#
dtype::form::metadata::widgets -object_type $object_type \
-dform $dform \
- -exclude_static_p $exclude_static_p \
+ -exclude_static_p $exclude_static_p \
-multirow widgets
-
+
dtype::form::metadata::params -object_type $object_type \
-dform $dform \
-multirow params \
- -exclude $exclude
+ -exclude $exclude
set widget_count [template::multirow size widgets]
set param_count [template::multirow size params]
@@ -550,56 +549,56 @@
# Generate form elements for each attribute / widget
for {set w 1} {$w <= $widget_count} {incr w} {
- template::multirow get widgets $w
+ template::multirow get widgets $w
set html_options [list]
set widget_options [list]
- # exclude specified widgets
- if {[lsearch -exact $exclude $widgets(attribute_name)] > -1} {
- continue
- }
+ # exclude specified widgets
+ if {[lsearch -exact $exclude $widgets(attribute_name)] > -1} {
+ continue
+ }
# set the default values for overridable options
- set overridables(help_text) "[_ acs-translations.$widgets(object_type)\_$widgets(attribute_name)\_help]"
- set message_key "acs-translations.$widgets(object_type)\_$widgets(attribute_name)"
- if {[lang::message::message_exists_p $default_locale $message_key]} {
- set overridables(label) "[_ $message_key]"
- } else {
- set overridables(label) $widgets(pretty_name)
- }
+ set overridables(help_text) "[_ acs-translations.$widgets(object_type)\_$widgets(attribute_name)\_help]"
+ set message_key "acs-translations.$widgets(object_type)\_$widgets(attribute_name)"
+ if {[lang::message::message_exists_p $default_locale $message_key]} {
+ set overridables(label) "[_ $message_key]"
+ } else {
+ set overridables(label) $widgets(pretty_name)
+ }
# Create the main element create line
set element_create_cmd "template::element create \
- \$form \${prefix}\$widgets(attribute_name) \
- -widget \$widgets(widget) \
- -datatype \$widgets(datatype) \
- -section \$section \
- -nospell"
+ \$form \${prefix}\$widgets(attribute_name) \
+ -widget \$widgets(widget) \
+ -datatype \$widgets(datatype) \
+ -section \$section \
+ -nospell"
if {![template::util::is_true $widgets(is_required)]} {
append element_create_cmd " -optional"
}
if {![string equal $widgets(widget) file]} {
- # Append the initial value
- if {[info exists override($widgets(attribute_name))]} {
- regsub -all {\"} $override($widgets(attribute_name)) {\\"} override($widgets(attribute_name))
+ # Append the initial value
+ if {[info exists override($widgets(attribute_name))]} {
+ regsub -all {\"} $override($widgets(attribute_name)) {\\"} override($widgets(attribute_name))
append element_create_cmd " [dtype::form::value_switch \
-widget $widgets(widget) \
-value $override($widgets(attribute_name))]"
} elseif {$new_p} {
- append element_create_cmd " [dtype::form::value_switch \
- -widget $widgets(widget) \
- -value $widgets(default_value)]"
- } else {
- regsub -all {\"} $object($widgets(attribute_name)) {\\"} object($widgets(attribute_name))
- append element_create_cmd " [dtype::form::value_switch \
- -widget $widgets(widget) \
- -value $object($widgets(attribute_name))]"
- }
+ append element_create_cmd " [dtype::form::value_switch \
+ -widget $widgets(widget) \
+ -value $widgets(default_value)]"
+ } else {
+ regsub -all {\"} $object($widgets(attribute_name)) {\\"} object($widgets(attribute_name))
+ append element_create_cmd " [dtype::form::value_switch \
+ -widget $widgets(widget) \
+ -value $object($widgets(attribute_name))]"
}
+ }
- ns_log Debug "CREATE::: $element_create_cmd"
+ ns_log Debug "CREATE::: $element_create_cmd"
# Get all the params for this element
for {set p 1} {$p <= $param_count} {incr p} {
template::multirow get params $p
@@ -608,7 +607,7 @@
# No more parameters for this widget, finish
# processing this element
# break;
- continue
+ continue
}
set value [lang::util::localize [dtype::form::parameter_value -parameter params -vars $variables]]
@@ -625,9 +624,9 @@
}
if {$params(param) == "options"} {
- lappend widget_options "-$params(param)"
- lappend widget_options $value
- }
+ lappend widget_options "-$params(param)"
+ lappend widget_options $value
+ }
if {!$null_value_p || $params(param) == "options"} {
if {[template::util::is_true $params(is_html)]} {
@@ -670,7 +669,7 @@
}
array set cr_options_array $cr_widget_options
-
+
if {[string equal $object_type "content_revision"] &&
![string equal $cr_widget "none"]} {
@@ -715,7 +714,7 @@
{-widget:required}
{-value:required}
} {
- Return a -value or -values switch appropriately
+ Return a -value or -values switch appropriately
} {
switch $widget {
file {}
@@ -757,7 +756,7 @@
ad_proc -private dtype::write_utf8_file {
content
} {
- Write a temporary file in utf-8 character encoding containing the text
+ Write a temporary file in utf-8 character encoding containing the text
supplied.
} {
set tmp_file [ns_tmpnam]
@@ -766,7 +765,7 @@
fconfigure $fd -encoding utf-8
puts $fd $content
-
+
close $fd
return $tmp_file
}
@@ -775,8 +774,8 @@
{-object_id ""}
{-object_type ""}
} {
- Returns the type hierarchy for the supplied object_id or object_type. If
- both are supplied then the hierarchy of the object_id takes precedence
+ Returns the type hierarchy for the supplied object_id or object_type. If
+ both are supplied then the hierarchy of the object_id takes precedence
over the supplied type. When the object_type is used it is included in the
returned list.
} {
@@ -792,7 +791,7 @@
{-parameter:required}
{-vars:required}
} {
- Calculates and returns the current value for the supplied parameter array
+ Calculates and returns the current value for the supplied parameter array
based on its type, source and default_value attributes.
Provide variables to tcl-procs by \$variables(--name--)
} {
@@ -825,7 +824,7 @@
if {$value eq ""} {
set value [list [list]]
}
- }
+ }
}
}] {
set name $param(param)
@@ -896,7 +895,7 @@
set metadata [dtype::form::metadata::widgets_list \
-object_type $object_type \
- -exclude_static_p $exclude_static_p \
+ -exclude_static_p $exclude_static_p \
-dform $dform]
foreach widget $metadata {
@@ -906,7 +905,7 @@
for {set i 0} {$i < [llength $keys]} {incr i} {
set row([lindex $keys $i]) [lindex $widget $i]
}
-
+
set result([lindex $widget 0]) [array get row]
}
}
@@ -918,19 +917,19 @@
{-dform:required}
{-exclude_static_p 0}
} {
- Returns a list of lists with the widget metadata for the specified
+ Returns a list of lists with the widget metadata for the specified
object_type and dform.
@param object_type the object type whose metadata will define the form
@param dform specifies the stored object form to use
@param no_cache does not attempt to use the cache to retrieve the info
} {
if {$no_cache_p} {
- if {$exclude_static_p} {
- return [db_list_of_lists select_dform_metadata_dynamic {}]
- } else {
- return [db_list_of_lists select_dform_metadata {}]
- }
+ if {$exclude_static_p} {
+ return [db_list_of_lists select_dform_metadata_dynamic {}]
+ } else {
+ return [db_list_of_lists select_dform_metadata {}]
+ }
} else {
return [util_memoize "dtype::form::metadata::widgets_list -no_cache -object_type \"$object_type\" -dform \"$dform\" -exclude_static_p $exclude_static_p"]
}
@@ -970,8 +969,8 @@
is_required \
is_html \
default_value \
- attribute_name
- ]
+ attribute_name
+ ]
if {$multirow_p} {
eval "template::multirow create \$multirow $keys"
@@ -982,21 +981,21 @@
set metadata [dtype::form::metadata::params_list \
-object_type $object_type \
-dform $dform]
-
+
foreach param $metadata {
- if {[empty_string_p $exclude] || [lsearch -exact $exclude [lindex $param 12]] == -1} {
+ if {[empty_string_p $exclude] || [lsearch -exact $exclude [lindex $param 12]] == -1} {
- if {$multirow_p} {
- eval "template::multirow append \$multirow $param"
- } else {
- for {set i 0} {$i < [llength $keys]} {incr i} {
- set row([lindex $keys $i]) [lindex $param $i]
- }
+ if {$multirow_p} {
+ eval "template::multirow append \$multirow $param"
+ } else {
+ for {set i 0} {$i < [llength $keys]} {incr i} {
+ set row([lindex $keys $i]) [lindex $param $i]
+ }
- set row_key [lindex $param 1],[lindex $param 8]
- set result($row_key) [array get row]
- }
- }
+ set row_key [lindex $param 1],[lindex $param 8]
+ set result($row_key) [array get row]
+ }
+ }
}
}
@@ -1005,7 +1004,7 @@
{-object_type:required}
{-dform:required}
} {
- Returns a list of lists with the widget parameter metadata for the
+ Returns a list of lists with the widget parameter metadata for the
specified object_type and dform.
@param object_type the object type whose metadata will define the form
@@ -1030,7 +1029,7 @@
} {
upvar $event dtype_event
- set function "dtype::form::metadata::\[^ \]*_list -no_cache"
+ set function "dtype::form::metadata::\[^ \]*_list -no_cache"
set object_type "-object_type \"$dtype_event(object_type)\""
if {[string equal $type dtype] || [string equal $type dtype.attribute]} {
@@ -1053,7 +1052,7 @@
if {[llength $datatypes] > 0} {
set datatype_clause "and wt.datatype in ('[join $datatypes "', '"]')"
}
-
+
db_multirow $multirow select_widget_templates {}
}
@@ -1148,7 +1147,7 @@
Create a widget and corresponding parameters according to the
specified template.
} {
- dtype::form::metadata::widget_template -template $template_name template
+ dtype::form::metadata::widget_template -template $template_name template
dtype::form::metadata::widget_template_params -template $template_name \
template_params
@@ -1160,7 +1159,7 @@
-dform $dform \
-attribute_name $attribute_name \
-widget $template(widget) \
- -required_p $required_p
+ -required_p $required_p
for {set i 1} {$i <= $size} {incr i} {
template::multirow get template_params $i
@@ -1173,9 +1172,9 @@
-type $template_params(param_type) \
-source $template_params(param_source) \
-value $template_params(value)
- }
- }
-}
+ }
+ }
+}
ad_proc -public dtype::form::metadata::delete_attribute_widgets {
{-object_type:required}
@@ -1223,3 +1222,9 @@
set event(action) updated
util::event::fire -event dtype.form event
}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/glossar/tcl/glossar-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/glossar/tcl/glossar-procs.tcl,v
diff -u -r1.5 -r1.6
--- openacs-4/packages/glossar/tcl/glossar-procs.tcl 12 Feb 2019 18:00:04 -0000 1.5
+++ openacs-4/packages/glossar/tcl/glossar-procs.tcl 12 Feb 2019 18:45:14 -0000 1.6
@@ -1,7 +1,4 @@
ad_library {
-
-
-
@author Bjoern Kiesbye (bjoern_kiesbye@web.de)
@author Nils Lohse (nils.lohse@cognovis.de)
@creation-date 2005-07-06
@@ -33,29 +30,29 @@
New Glossar
} {
if {[empty_string_p $package_id]} {
- set package_id [ad_conn package_id]
+ set package_id [ad_conn package_id]
}
set folder_id [content::folder::get_folder_from_package -package_id $package_id]
set item_id [db_nextval acs_object_id_seq]
db_transaction {
- if {[empty_string_p $name]} {
- set name "gl_glossar_$item_id"
- }
- set item_id [content::item::new -parent_id $folder_id -content_type {gl_glossar} -name $name -package_id $package_id -item_id $item_id]
+ if {[empty_string_p $name]} {
+ set name "gl_glossar_$item_id"
+ }
+ set item_id [content::item::new -parent_id $folder_id -content_type {gl_glossar} -name $name -package_id $package_id -item_id $item_id]
- set new_id [content::revision::new \
- -item_id $item_id \
- -content_type {gl_glossar} \
- -title $title \
- -description $description \
- -attributes [list \
- [list owner_id $owner_id] \
- [list source_category_id $source_category_id] \
- [list target_category_id $target_category_id] \
- [list etat_id $etat_id] \
- ] ]
+ set new_id [content::revision::new \
+ -item_id $item_id \
+ -content_type {gl_glossar} \
+ -title $title \
+ -description $description \
+ -attributes [list \
+ [list owner_id $owner_id] \
+ [list source_category_id $source_category_id] \
+ [list target_category_id $target_category_id] \
+ [list etat_id $etat_id] \
+ ] ]
}
return $new_id
@@ -78,22 +75,19 @@
Edit Glossar
} {
set new_rev_id [content::revision::new \
- -item_id $glossar_item_id \
- -content_type {gl_glossar} \
- -title $title \
- -description $description \
- -attributes [list \
- [list owner_id $owner_id] \
- [list source_category_id $source_category_id] \
- [list target_category_id $target_category_id] \
- [list etat_id $etat_id] \
- ] ]
+ -item_id $glossar_item_id \
+ -content_type {gl_glossar} \
+ -title $title \
+ -description $description \
+ -attributes [list \
+ [list owner_id $owner_id] \
+ [list source_category_id $source_category_id] \
+ [list target_category_id $target_category_id] \
+ [list etat_id $etat_id] \
+ ] ]
return $new_rev_id
}
-
-
-
ad_proc -public glossar::term::new {
-glossar_id:required
{-term_id ""}
@@ -114,28 +108,28 @@
New Glossar Term
} {
if {[empty_string_p $package_id]} {
- set package_id [ad_conn package_id]
+ set package_id [ad_conn package_id]
}
set item_id [db_nextval acs_object_id_seq]
db_transaction {
- if {[empty_string_p $name]} {
- set name "gl_glossar_term_$item_id"
- }
- set item_id [content::item::new -parent_id $glossar_id -content_type {gl_glossar_term} -name $name -package_id $package_id -item_id $item_id]
+ if {[empty_string_p $name]} {
+ set name "gl_glossar_term_$item_id"
+ }
+ set item_id [content::item::new -parent_id $glossar_id -content_type {gl_glossar_term} -name $name -package_id $package_id -item_id $item_id]
- set new_id [content::revision::new \
- -item_id $item_id \
- -content_type {gl_glossar_term} \
- -title $title \
- -description $description \
- -attributes [list \
- [list source_text $source_text] \
- [list target_text $target_text] \
- [list dont_text $dont_text] \
- [list owner_id $customer_id] \
- ] ]
+ set new_id [content::revision::new \
+ -item_id $item_id \
+ -content_type {gl_glossar_term} \
+ -title $title \
+ -description $description \
+ -attributes [list \
+ [list source_text $source_text] \
+ [list target_text $target_text] \
+ [list dont_text $dont_text] \
+ [list owner_id $customer_id] \
+ ] ]
}
return $new_id
@@ -160,16 +154,16 @@
Edit Glossar Term
} {
set new_rev_id [content::revision::new \
- -item_id $term_id \
- -content_type {gl_glossar_term} \
- -title $title \
- -description $description \
- -attributes [list \
- [list source_text $source_text] \
- [list target_text $target_text] \
- [list dont_text $dont_text] \
- [list owner_id $customer_id]
- ] ]
+ -item_id $term_id \
+ -content_type {gl_glossar_term} \
+ -title $title \
+ -description $description \
+ -attributes [list \
+ [list source_text $source_text] \
+ [list target_text $target_text] \
+ [list dont_text $dont_text] \
+ [list owner_id $customer_id]
+ ] ]
return $new_rev_id
}
@@ -183,16 +177,16 @@
@creation-date 2006-08-03
Delete Glossar Term
-} {
+} {
db_transaction {
- permission::require_write_permission -object_id $term_id
+ permission::require_write_permission -object_id $term_id
ns_log Notice "Deleting glossar term $term_id"
- content::item::delete -item_id $term_id
- }
+ content::item::delete -item_id $term_id
+ }
}
# created 2006/08/03 by cognovis/nfl
-# finished 2006/08/04 by cognovis/nfl
+# finished 2006/08/04 by cognovis/nfl
ad_proc -public glossar::glossary::delete {
-glossar_item_id:required
} {
@@ -202,13 +196,19 @@
Delete Glossar
} {
#db_transaction {
- # First, delete all terms
- # ... it's done automatically by deleting the glossar itself. Cool.
- # Second, delete the Glossar itself
- db_transaction {
- permission::require_write_permission -object_id $glossar_item_id
- ns_log Notice "Deleting glossar $glossar_item_id"
- content::item::delete -item_id $glossar_item_id
- }
+ # First, delete all terms
+ # ... it's done automatically by deleting the glossar itself. Cool.
+ # Second, delete the Glossar itself
+ db_transaction {
+ permission::require_write_permission -object_id $glossar_item_id
+ ns_log Notice "Deleting glossar $glossar_item_id"
+ content::item::delete -item_id $glossar_item_id
+ }
#}
}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/glossar/www/glossar-add.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/glossar/www/glossar-add.tcl,v
diff -u -r1.9 -r1.10
--- openacs-4/packages/glossar/www/glossar-add.tcl 12 Feb 2019 18:00:04 -0000 1.9
+++ openacs-4/packages/glossar/www/glossar-add.tcl 12 Feb 2019 18:45:14 -0000 1.10
@@ -1,7 +1,7 @@
ad_page_contract {
-
+
Adding a Glossar to a Eta/User
-
+
@author Bjoern Kiesbye (bjoern_kiesbye@web.de)
@creation-date 2005-07-09
@cvs-id $Id$
@@ -17,15 +17,15 @@
if {$gl_translation_p == 1} {
if {[exists_and_not_null glossar_id]} {
- set page_title "[_ glossar.Edit_Translation]"
+ set page_title "[_ glossar.Edit_Translation]"
} else {
- set page_title "[_ glossar.New_Translation]"
+ set page_title "[_ glossar.New_Translation]"
}
} else {
if {[exists_and_not_null glossar_id]} {
- set page_title "[_ glossar.Edit_Glossar]"
+ set page_title "[_ glossar.Edit_Glossar]"
} else {
- set page_title "[_ glossar.Add_new_Glossar]"
+ set page_title "[_ glossar.Add_new_Glossar]"
}
}
@@ -45,28 +45,28 @@
{glossar_id:key}
{title:text(text) {label "[_ glossar.Title]"} }
{description:text(textarea),optional {label "[_ glossar.Comment]"} {html {rows 6 cols 80} }}
-}
+}
if {$gl_translation_p == 1} {
ad_form -extend -name glossar-add -form {
-
- {source_category_id:integer(category) {label "[_ glossar.glossar_source_category]"} {category_tree_id $source_tree_id} {category_assign_single_p t} {category_require_category_p t}}
- {target_category_id:integer(category) {label "[_ glossar.glossar_target_category]"} {category_tree_id $target_tree_id} {category_assign_single_p t} {category_require_category_p t}}
+ {source_category_id:integer(category) {label "[_ glossar.glossar_source_category]"} {category_tree_id $source_tree_id} {category_assign_single_p t} {category_require_category_p t}}
- }
+ {target_category_id:integer(category) {label "[_ glossar.glossar_target_category]"} {category_tree_id $target_tree_id} {category_assign_single_p t} {category_require_category_p t}}
+ }
+
} else {
ad_form -extend -name glossar-add -form {
-
- {source_category_id:integer(category) {label "[_ glossar.glossar_single_category]"} {category_tree_id $source_tree_id} {category_assign_single_p t} {category_require_category_p t}}
- {target_category_id:text(hidden) {value ""}}
+ {source_category_id:integer(category) {label "[_ glossar.glossar_single_category]"} {category_tree_id $source_tree_id} {category_assign_single_p t} {category_require_category_p t}}
- }
+ {target_category_id:text(hidden) {value ""}}
+ }
+
}
set group_id [group::get_id -group_name "Etat"]
@@ -77,23 +77,23 @@
if {[llength $options] > 1} {
ad_form -extend -name glossar-add -form {
- {target_id:integer(select),optional {label "[_ glossar.glossar_etat]"} {options $options}}
+ {target_id:integer(select),optional {label "[_ glossar.glossar_etat]"} {options $options}}
}
} else {
ad_form -extend -name glossar-add -form {
- {target_id:text(hidden) {value ""}}
+ {target_id:text(hidden) {value ""}}
}
}
ad_form -extend -name glossar-add \
--new_request {
- set source_category_id ""
- set target_category_id ""
- set description ""
- set title ""
+ -new_request {
+ set source_category_id ""
+ set target_category_id ""
+ set description ""
+ set title ""
} -edit_request {
db_1row get_glossar { }
@@ -102,15 +102,15 @@
set old_owner_id $owner_id
if {![empty_string_p $target_id]} {
- db_1row get_rel_id {}
+ db_1row get_rel_id {}
}
} -new_data {
-
+
if {![info exists target_category_id]} {
- set target_category_id ""
+ set target_category_id ""
}
-
+
glossar::glossary::new -owner_id $owner_id -title "$title" -description "$description" -source_category_id $source_category_id -target_category_id $target_category_id -package_id $package_id -etat_id ""
} -edit_data {
@@ -121,3 +121,9 @@
ad_returnredirect "/contacts/$old_owner_id"
ad_script_abort
}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/glossar/www/glossar-edit.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/glossar/www/glossar-edit.tcl,v
diff -u -r1.8 -r1.9
--- openacs-4/packages/glossar/www/glossar-edit.tcl 12 Feb 2019 18:00:04 -0000 1.8
+++ openacs-4/packages/glossar/www/glossar-edit.tcl 12 Feb 2019 18:45:14 -0000 1.9
@@ -1,7 +1,7 @@
ad_page_contract {
-
+
Change a Glossar
-
+
@author Bjoern Kiesbye (bjoern_kiesbye@web.de)
@creation-date 2005-07-09
@cvs-id $Id$
@@ -34,20 +34,20 @@
if {$translation_p == "t"} {
ad_form -extend -name glossar-edit -form {
-
- {source_category_id:integer(category) {label "[_ glossar.glossar_source_category]"} {category_tree_id $source_tree_id} {category_assign_single_p t} {category_require_category_p t} {category_mapped $source_cat_id}}
- {target_category_id:integer(category) {label "[_ glossar.glossar_target_category]"} {category_tree_id $target_tree_id} {category_assign_single_p t} {category_require_category_p t} {category_mapped $target_cat_id}}
+ {source_category_id:integer(category) {label "[_ glossar.glossar_source_category]"} {category_tree_id $source_tree_id} {category_assign_single_p t} {category_require_category_p t} {category_mapped $source_cat_id}}
- }
+ {target_category_id:integer(category) {label "[_ glossar.glossar_target_category]"} {category_tree_id $target_tree_id} {category_assign_single_p t} {category_require_category_p t} {category_mapped $target_cat_id}}
+ }
+
} else {
ad_form -extend -name glossar-edit -form {
- {source_category_id:integer(category) {label "[_ glossar.glossar_single_category]"} {category_tree_id $source_tree_id} {category_assign_single_p t} {category_require_category_p t} {category_mapped $source_cat_id}}
+ {source_category_id:integer(category) {label "[_ glossar.glossar_single_category]"} {category_tree_id $source_tree_id} {category_assign_single_p t} {category_require_category_p t} {category_mapped $source_cat_id}}
- {target_category_id:text(hidden) {value ""}}
- }
+ {target_category_id:text(hidden) {value ""}}
+ }
}
@@ -65,11 +65,11 @@
if {[llength $options] > 1} {
ad_form -extend -name glossar-edit -form {
- {target_id:integer(select),optional {label $target_label} {options $options}}
+ {target_id:integer(select),optional {label $target_label} {options $options}}
}
} else {
ad_form -extend -name glossar-edit -form {
- {target_id:text(hidden) {value ""}}
+ {target_id:text(hidden) {value ""}}
}
}
@@ -80,18 +80,18 @@
set organization_p [organization::organization_p -party_id $owner_id]
if {!$organization_p} {
- db_1row get_rel_id {}
+ db_1row get_rel_id {}
}
if {[exists_and_not_null rel_target_id]} {
- set target_id $rel_target_id
+ set target_id $rel_target_id
}
} -edit_data {
set old_owner_id $owner_id
if {![empty_string_p $target_id]} {
- db_1row get_rel_id2 {}
+ db_1row get_rel_id2 {}
}
glossar::glossary::edit -glossar_item_id $glossar_id -title $title -description $description -source_category_id $source_category_id -target_category_id $target_category_id -owner_id $owner_id -etat_id ""
@@ -101,3 +101,9 @@
ad_returnredirect "/contacts/$contact_id"
ad_script_abort
}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/image-magick/tcl/image-magick-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/image-magick/tcl/image-magick-procs.tcl,v
diff -u -r1.4 -r1.5
--- openacs-4/packages/image-magick/tcl/image-magick-procs.tcl 12 Feb 2019 18:00:04 -0000 1.4
+++ openacs-4/packages/image-magick/tcl/image-magick-procs.tcl 12 Feb 2019 18:45:14 -0000 1.5
@@ -27,7 +27,7 @@
Returns the full path to the ImageMagick convert binary.
} {
return "[bin_path]convert"
-
+
}
ad_proc -public ::ImageMagick::identify_path {
@@ -45,7 +45,7 @@
output_file
} {
Invokes the ImageMagick convert command with the given arguments.
- Ultimately, all options to convert will be encapsulated as switch
+ Ultimately, all options to convert will be encapsulated as switch
parameters to this procedure, and validation can be done on that.
However, until this is done, the <code>options</code> parameter
can be used to specify arbitrary extra parameters.
@@ -327,3 +327,9 @@
} {
db_exec_plsql del {}
}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/jabber/www/edit-external-contact-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/jabber/www/edit-external-contact-2.tcl,v
diff -u -r1.2 -r1.3
--- openacs-4/packages/jabber/www/edit-external-contact-2.tcl 12 Feb 2019 18:00:04 -0000 1.2
+++ openacs-4/packages/jabber/www/edit-external-contact-2.tcl 12 Feb 2019 18:45:14 -0000 1.3
@@ -1,6 +1,7 @@
ad_page_contract {
updates the database
+
@author Luis Mosteiro Fernandez
@creation-date 2002-10-23
@param screen_id who should be updated
@@ -16,8 +17,8 @@
im_screen_name:array
im_screen_name_old:array
services:array
-} -properties {
-
+} -properties {
+
}
set user_id [ad_conn user_id]
@@ -26,130 +27,106 @@
if {$friend_first_name != $friend_first_name_old} {
-db_dml update_first_name "UPDATE jb_friends SET friend_first_name = :friend_first_name
- WHERE friend_first_name = :friend_first_name_old
- AND friend_last_name = :friend_last_name_old
- AND user_id = :user_id"
+ db_dml update_first_name "UPDATE jb_friends SET friend_first_name = :friend_first_name
+ WHERE friend_first_name = :friend_first_name_old
+ AND friend_last_name = :friend_last_name_old
+ AND user_id = :user_id"
-set friend_first_name_old "$friend_first_name"
+ set friend_first_name_old "$friend_first_name"
}
-
if {$friend_last_name != $friend_last_name_old} {
-db_dml update_first_name "UPDATE jb_friends SET friend_last_name = :friend_last_name
- WHERE friend_first_name = :friend_first_name_old
- AND friend_last_name = :friend_last_name_old
- AND user_id = :user_id"
+ db_dml update_first_name "UPDATE jb_friends SET friend_last_name = :friend_last_name
+ WHERE friend_first_name = :friend_first_name_old
+ AND friend_last_name = :friend_last_name_old
+ AND user_id = :user_id"
-set friend_last_name_old "$friend_last_name"
+ set friend_last_name_old "$friend_last_name"
-
}
-
-
-
for {set search [array startsearch services]} { [array anymore services $search]} {} {
-
set cur_service_1 [array nextelement services $search]
set cur_service $services($cur_service_1)
-ns_log notice "cur_service = $cur_service , services(cur_service) = $services($cur_service_1)"
+ ns_log notice "cur_service = $cur_service , services(cur_service) = $services($cur_service_1)"
set old_screen $im_screen_name_old($cur_service)
set new_screen $im_screen_name($cur_service)
if {$new_screen != $old_screen} {
- if {$cur_service == "msn"} {
- regsub -all "@" $old_screen "%" old_screen
- regsub -all "@" $new_screen "%" new_screen
- }
+ if {$cur_service == "msn"} {
+ regsub -all "@" $old_screen "%" old_screen
+ regsub -all "@" $new_screen "%" new_screen
+ }
- if {$old_screen != "" } {
+ if {$old_screen != "" } {
- #remove from friends list
+ #remove from friends list
- db_1row get_old_screen_id "SELECT (screen_id) as old_screen_id , refcount FROM jb_screens WHERE im_screen_name = :old_screen AND service = :cur_service"
+ db_1row get_old_screen_id "SELECT (screen_id) as old_screen_id , refcount FROM jb_screens WHERE im_screen_name = :old_screen AND service = :cur_service"
- db_dml delete_from_friendslist "DELETE FROM jb_friends
- WHERE friend_screen_id = :old_screen_id
- AND user_id = :user_id"
+ db_dml delete_from_friendslist "DELETE FROM jb_friends
+ WHERE friend_screen_id = :old_screen_id
+ AND user_id = :user_id"
- if {$refcount > 1} {
- set refcount [expr $refcount - 1]
- db_dml update_refcount "UPDATE jb_screens SET refcount = :refcount WHERE im_screen_name = :old_screen AND service = :cur_service"
- } else {
-
- db_exec_plsql jb_screen_delete ""
-
- set success [jb_removetransportbuddy $old_screen [jb_get_transport_id_from_symbol $cur_service]]
+ if {$refcount > 1} {
+ set refcount [expr $refcount - 1]
+ db_dml update_refcount "UPDATE jb_screens SET refcount = :refcount WHERE im_screen_name = :old_screen AND service = :cur_service"
+ } else {
- }
+ db_exec_plsql jb_screen_delete ""
- }
-
- if { $new_screen != "" } {
- # check if we alreddy have this screen in the jb_screens table
- if { [ db_0or1row get_new_screen_id "SELECT (screen_id) as new_screen_id , (refcount) as new_refcount FROM jb_screens WHERE im_screen_name = :new_screen AND service = :cur_service"]} {
-
-
- #we know this screen just update the friends table.
-
- db_dml insert_new_frind "INSERT INTO jb_friends (friend_first_name , friend_last_name , friend_screen_id , user_id) values (:friend_first_name_old , :friend_last_name_old , :new_screen_id , :user_id)"
+ set success [jb_removetransportbuddy $old_screen [jb_get_transport_id_from_symbol $cur_service]]
- set new_refcount [expr $new_refcount +1]
-
- db_dml update_refcount_with_screen_id "UPDATE jb_screens SET refcount = :new_refcount WHERE screen_id = :new_screen_id"
+ }
+ }
- } else {
-
- #we have a total new screen
+ if { $new_screen != "" } {
+ # check if we alreddy have this screen in the jb_screens table
+ if { [ db_0or1row get_new_screen_id "SELECT (screen_id) as new_screen_id , (refcount) as new_refcount FROM jb_screens WHERE im_screen_name = :new_screen AND service = :cur_service"]} {
-
- #create a new jb_screen object for the new screen name
- db_exec_plsql new_screen {}
-
- #now add the new screen to the jabber roster
- set success [jb_addtransportbuddy $new_screen "online-trace" [jb_get_transport_id_from_symbol $cur_service]]
-
-
- db_1row get_new_screen_id "SELECT (screen_id) as new_screen_id , (refcount) as new_refcount
- FROM jb_screens
- WHERE im_screen_name = :new_screen
- AND service = :cur_service"
- db_dml insert_new_frind "INSERT INTO jb_friends (friend_first_name , friend_last_name , friend_screen_id , user_id)
- VALUES (:friend_first_name_old , :friend_last_name_old , :new_screen_id , :user_id)"
-
- }
+ #we know this screen just update the friends table.
+ db_dml insert_new_frind "INSERT INTO jb_friends (friend_first_name , friend_last_name , friend_screen_id , user_id) values (:friend_first_name_old , :friend_last_name_old , :new_screen_id , :user_id)"
-
- }
-
+ set new_refcount [expr $new_refcount +1]
-
+ db_dml update_refcount_with_screen_id "UPDATE jb_screens SET refcount = :new_refcount WHERE screen_id = :new_screen_id"
+ } else {
+ #we have a total new screen
- }
-
+ #create a new jb_screen object for the new screen name
+ db_exec_plsql new_screen {}
+ #now add the new screen to the jabber roster
+ set success [jb_addtransportbuddy $new_screen "online-trace" [jb_get_transport_id_from_symbol $cur_service]]
+ db_1row get_new_screen_id "SELECT (screen_id) as new_screen_id , (refcount) as new_refcount
+ FROM jb_screens
+ WHERE im_screen_name = :new_screen
+ AND service = :cur_service"
+ db_dml insert_new_frind "INSERT INTO jb_friends (friend_first_name , friend_last_name , friend_screen_id , user_id)
+ VALUES (:friend_first_name_old , :friend_last_name_old , :new_screen_id , :user_id)"
-
-
+ }
+ }
+ }
}
-
-
-
-
-
ad_returnredirect "view-external-contacts"
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/jabber/www/edit-user-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/jabber/www/edit-user-2.tcl,v
diff -u -r1.4 -r1.5
--- openacs-4/packages/jabber/www/edit-user-2.tcl 12 Feb 2019 18:00:04 -0000 1.4
+++ openacs-4/packages/jabber/www/edit-user-2.tcl 12 Feb 2019 18:45:14 -0000 1.5
@@ -1,17 +1,15 @@
ad_page_contract {
updates existing user preferences
+
@author Luis Mosteiro Fernandez
@creation-date 2002-10-22
@param screen_name array of new/old screen names
-
-} {
+} {
screen_name:array
-
}
-
set user_id [ad_conn user_id]
set db_nulling ""
set peeraddr [ad_conn peeraddr]
@@ -20,148 +18,145 @@
db_foreach get_services "Select service from jb_services where active_check_p = 't'" {
set screen_id "-1"
set refcount "0"
- set user_screen_name $screen_name($service)
+ set user_screen_name $screen_name($service)
if {$service == "msn"} {
- regsub -all "@" $user_screen_name "%" user_screen_name
-
+ regsub -all "@" $user_screen_name "%" user_screen_name
}
if {[empty_string_p $screen_name($service)]} {
- ns_log debug "edit-user-2 2 $user_screen_name"
- #the user did not enter a screen for this service, so just remove old stuff
- if {[db_0or1row get_screen_id "SELECT screen_id , refcount , im_screen_name
- FROM jb_screens
- WHERE user_id = :user_id
+ ns_log debug "edit-user-2 2 $user_screen_name"
+ #the user did not enter a screen for this service, so just remove old stuff
+ if {[db_0or1row get_screen_id "SELECT screen_id , refcount , im_screen_name
+ FROM jb_screens
+ WHERE user_id = :user_id
AND service = :service"]} {
ns_log debug "edit-user-2 2.1"
#we have a screen for this user_id and no new , so we have to 1. completely remove the screen from jb_screens if no one else
#is interestet in this screen refcount = 1 and remove it from the jabber roster.
#2. just delete the user_id from the screen_id
-
- set old_screen_name $im_screen_name
+ set old_screen_name $im_screen_name
+
if { $refcount == 1 } {
- set old_screen_id $screen_id
+ set old_screen_id $screen_id
- db_exec_plsql jb_screen_delete {
- begin
- jb_screen.delete(:screen_id);
- end;
- }
-
- set old_screen_id ""
-
- # db_dml delete_screen "delete from jb_screens where user_id = :user_id and service = :service"
- set success [jb_removetransportbuddy $old_screen_name [jb_get_transport_id_from_symbol $service]]
-
+ db_exec_plsql jb_screen_delete {
+ begin
+ jb_screen.delete(:screen_id);
+ end;
+ }
- } else {
- ns_log debug "edit-user-2 2.1.2"
-
- db_dml update_screen "UPDATE jb_screens SET user_id = :db_nulling WHERE user_id = :user_id AND service = :service"
- }
+ set old_screen_id ""
+ # db_dml delete_screen "delete from jb_screens where user_id = :user_id and service = :service"
+ set success [jb_removetransportbuddy $old_screen_name [jb_get_transport_id_from_symbol $service]]
- } else { ns_log debug "edit-user-2 2.2"
- # we have no screen in the db , and no new one , nothing to do.
- }
+ } else {
+ ns_log debug "edit-user-2 2.1.2"
+
+ db_dml update_screen "UPDATE jb_screens SET user_id = :db_nulling WHERE user_id = :user_id AND service = :service"
+ }
+
+ } else { ns_log debug "edit-user-2 2.2"
+ # we have no screen in the db , and no new one , nothing to do.
+ }
} else {
- ns_log debug "edit-user-2 3"
- #we have a new screen , see if we have one in the jb_screens table
+ ns_log debug "edit-user-2 3"
+ #we have a new screen , see if we have one in the jb_screens table
- if {[db_0or1row get_screen_id "select (screen_id) as old_screen_id , (im_screen_name) as old_screen_name , refcount from jb_screens where user_id = :user_id and service = :service"]} {
- ns_log debug "edit-user-2 3.1"
- #we have a screen in the db , see if it's a new one.
- if { $old_screen_name != $user_screen_name } {
- ns_log debug "edit-user-2 3.1.1"
- #we have a new screen , see if we can just update the OLD table column
- if { [db_0or1row check_new_screen_exists "SELECT (screen_id) as new_screen_id
- FROM jb_screens
- WHERE im_screen_name = :user_screen_name
- AND service = :service"]} {
+ if {[db_0or1row get_screen_id "select (screen_id) as old_screen_id , (im_screen_name) as old_screen_name , refcount from jb_screens where user_id = :user_id and service = :service"]} {
+ ns_log debug "edit-user-2 3.1"
+ #we have a screen in the db , see if it's a new one.
+ if { $old_screen_name != $user_screen_name } {
+ ns_log debug "edit-user-2 3.1.1"
+ #we have a new screen , see if we can just update the OLD table column
+ if { [db_0or1row check_new_screen_exists "SELECT (screen_id) as new_screen_id
+ FROM jb_screens
+ WHERE im_screen_name = :user_screen_name
+ AND service = :service"]} {
- ns_log debug "edit-user-2 3.1.1.1"
- #ok we already have a new screen_id for this screen, so remove the user_id from the old screen_id and may drop the whole
- #column , or just update the user_id , old column to null and the new one to :user_id
- if { $refcount == 1 } {
- ns_log debug "edit-user-2 3.1.1.1.1"
- # no one is interested in the old screen so remove the whole column
- # we have to do it with the delete function (ACSOBJECT)
- # till then we just delete the user_id
+ ns_log debug "edit-user-2 3.1.1.1"
+ #ok we already have a new screen_id for this screen, so remove the user_id from the old screen_id and may drop the whole
+ #column , or just update the user_id , old column to null and the new one to :user_id
+ if { $refcount == 1 } {
+ ns_log debug "edit-user-2 3.1.1.1.1"
+ # no one is interested in the old screen so remove the whole column
+ # we have to do it with the delete function (ACSOBJECT)
+ # till then we just delete the user_id
+ db_exec_plsql jb_screen_delete ""
- db_exec_plsql jb_screen_delete ""
-
-
- set success [jb_removetransportbuddy $old_screen_name [jb_get_transport_id_from_symbol $service]]
+ set success [jb_removetransportbuddy $old_screen_name [jb_get_transport_id_from_symbol $service]]
- } else {
- ns_log debug "edit-user-2 3.1.1.1.2"
- #just remove the user_id in the old column , and put it in the new column
- db_dml remove_old_user_id "UPDATE jb_screens SET user_id = :db_nulling WHERE screen_id = :old_screen_id"
- db_dml update_new_screens_column "UPDATE jb_screens SET user_id = :user_id WHERE screen_id = :new_screen_id"
-
- }
+ } else {
+ ns_log debug "edit-user-2 3.1.1.1.2"
+ #just remove the user_id in the old column , and put it in the new column
+ db_dml remove_old_user_id "UPDATE jb_screens SET user_id = :db_nulling WHERE screen_id = :old_screen_id"
+ db_dml update_new_screens_column "UPDATE jb_screens SET user_id = :user_id WHERE screen_id = :new_screen_id"
- } else {
- ns_log debug "edit-user-2 3.1.1.2"
- #the new screen doesn't exists jet create a new one and delete the user_id from the old
-
- if { $refcount == 1 } {
-ns_log debug "edit-user-2 3.1.1.2.1"
- # no one is interested in the old screen so remove the whole column
- # we have to do it with the delete function (ACSOBJECT)
- # till then we just delete the user_id
+ }
-
- db_exec_plsql jb_screen_delete ""
-
- set success [jb_removetransportbuddy $old_screen_name [jb_get_transport_id_from_symbol $service]]
+ } else {
+ ns_log debug "edit-user-2 3.1.1.2"
+ #the new screen doesn't exists jet create a new one and delete the user_id from the old
- } else {
-ns_log debug "edit-user-2 3.1.1.2.2"
- #just remove the user_id in the old column
- db_dml remove_old_user_id "UPDATE jb_screens SET user_id = :db_nulling WHERE screen_id = :old_screen_id"
+ if { $refcount == 1 } {
+ ns_log debug "edit-user-2 3.1.1.2.1"
+ # no one is interested in the old screen so remove the whole column
+ # we have to do it with the delete function (ACSOBJECT)
+ # till then we just delete the user_id
- }
- #create a new jb_screen object for the new screen name
- db_exec_plsql new_screen {}
+ db_exec_plsql jb_screen_delete ""
- #now add the new screen to the jabber roster
- set success [jb_addtransportbuddy $user_screen_name "online-trace" [jb_get_transport_id_from_symbol $service]]
+ set success [jb_removetransportbuddy $old_screen_name [jb_get_transport_id_from_symbol $service]]
- }
+ } else {
+ ns_log debug "edit-user-2 3.1.1.2.2"
+ #just remove the user_id in the old column
+ db_dml remove_old_user_id "UPDATE jb_screens SET user_id = :db_nulling WHERE screen_id = :old_screen_id"
+ }
-
- } else {
-ns_log debug "edit-user-2 3.1.2"
+ #create a new jb_screen object for the new screen name
+ db_exec_plsql new_screen {}
- #old and new screen name match so do nothing
- }
- } else {
-ns_log debug "edit-user-2 3.2"
- #we have no old_screen_id for this user_id, so check if we have to fully create a new one, or just inserting the old user_id.
- if { [db_0or1row check_new_screen_exists "SELECT (screen_id) as new_screen_id
- FROM jb_screens
- WHERE im_screen_name = :user_screen_name
- AND service = :service"]} {
+ #now add the new screen to the jabber roster
+ set success [jb_addtransportbuddy $user_screen_name "online-trace" [jb_get_transport_id_from_symbol $service]]
+ }
-
- #just update the user_id column
- db_dml insert_new_user_id "UPDATE jb_screens SET user_id = :user_id WHERE screen_id = :new_screen_id"
-
+ } else {
+ ns_log debug "edit-user-2 3.1.2"
- } else {
- db_exec_plsql new_screen {}
-
- #now add the new screen to the jabber roster
- set success [jb_addtransportbuddy $user_screen_name "online-trace" [jb_get_transport_id_from_symbol $service]]
- }
- }
+ #old and new screen name match so do nothing
+ }
+ } else {
+ ns_log debug "edit-user-2 3.2"
+ #we have no old_screen_id for this user_id, so check if we have to fully create a new one, or just inserting the old user_id.
+ if { [db_0or1row check_new_screen_exists "SELECT (screen_id) as new_screen_id
+ FROM jb_screens
+ WHERE im_screen_name = :user_screen_name
+ AND service = :service"]} {
+
+
+ #just update the user_id column
+ db_dml insert_new_user_id "UPDATE jb_screens SET user_id = :user_id WHERE screen_id = :new_screen_id"
+
+ } else {
+ db_exec_plsql new_screen {}
+
+ #now add the new screen to the jabber roster
+ set success [jb_addtransportbuddy $user_screen_name "online-trace" [jb_get_transport_id_from_symbol $service]]
+ }
+ }
}
-}
-
+}
+
ad_returnredirect "index.tcl"
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/learning-content/tcl/learning-content-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/learning-content/tcl/learning-content-procs.tcl,v
diff -u -r1.5 -r1.6
--- openacs-4/packages/learning-content/tcl/learning-content-procs.tcl 12 Feb 2019 18:00:04 -0000 1.5
+++ openacs-4/packages/learning-content/tcl/learning-content-procs.tcl 12 Feb 2019 18:45:14 -0000 1.6
@@ -59,7 +59,7 @@
set page [::xowiki::Package instantiate_page_from_id -item_id $page_item_id]
set page_name [$page set name]
$page destroy_on_cleanup
-
+
if { ![empty_string_p $content] } {
$page set instance_attributes [list "contenido" $content]
}
@@ -207,7 +207,7 @@
foreach object $objects_map {
set item_id [lindex $object [expr [llength $object] - 1]]
set item_name [lindex $object 0]
- if { [learning_content::activity_exists_p -item_id $item_id] } {
+ if { [learning_content::activity_exists_p -item_id $item_id] } {
set new_item_id [db_string get_new_item_id { *SQL* } -default 0]
learning_content::activity_new -item_id $new_item_id -activity_id 0
}
@@ -218,7 +218,7 @@
{-src_folder_id:required}
{-dst_folder_id:required}
} {
- Copy the words count from the source instance of content
+ Copy the words count from the source instance of content
to a target instance
} {
db_foreach get_words_count { *SQL* } {
@@ -254,13 +254,13 @@
set list_of_expressions [split $page_content ">"]
foreach expression $list_of_expressions {
if {[regexp \
- /dotlrn(\[^"\]*)file-storage(\[^"\]*)(\\.)(...|....)(\") \
+ /dotlrn(\[^"\]*)file-storage(\[^"\]*)(\\.)(...|....)(\") \
$expression one_match]} {
set one_match [string trimright $one_match "\""]
set this_match [list $one_match [learning_content::replace_path \
-original_path $one_match \
-original_package_id $original_package_id \
- -new_package_id $new_package_id ] ]
+ -new_package_id $new_package_id ] ]
lappend match_list $this_match
}
}
@@ -298,7 +298,7 @@
set new_fs_package_id $new_fs_node_info(package_id)
set orig_root_folder [fs_get_root_folder -package_id $orig_fs_package_id ]
set new_root_folder [fs_get_root_folder -package_id $new_fs_package_id ]
- set fs_view_path [string range $original_path $view_start end]
+ set fs_view_path [string range $original_path $view_start end]
set fs_view_path [ns_urldecode $fs_view_path]
set file_id [::content::item::get_id -item_path " $fs_view_path " \
-root_folder_id $orig_root_folder \
@@ -313,7 +313,7 @@
set folder_list [split $fs_view_path "/"]
set root_folder $new_root_folder
foreach folder $folder_list {
- set folder [ns_urldecode $folder]
+ set folder [ns_urldecode $folder]
set folder_id [fs::get_folder -name "$folder" -parent_id $root_folder]
if { [empty_string_p $folder_id ] } {
set root_folder [fs::new_folder -name "$folder" \
@@ -518,7 +518,7 @@
dotlrn_community::add_applet_to_community \
$dst_community_id dotlrn_learning_content
set dst_package_id [db_string get_dst_package_id "" -default 0]
- $dst_package_id destroy
+ $dst_package_id destroy
}
::xowiki::Package initialize -parameter {
@@ -572,7 +572,7 @@
[$item_id set name] [$item_id item_id] }" \n
}
foreach item_id $item_ids {
- $item_id destroy
+ $item_id destroy
}
#getting the content categories
@@ -848,51 +848,51 @@
-wiki_folder_id
-state
} {
-
+
set tree_list [learning_content::category::get_tree_levels -subtree_id $category_id -tree_id $tree_id]
foreach one_category $tree_list {
- set cat_id [lindex $one_category 0]
- db_foreach select_page {
- select ci.item_id, r.revision_id, ci.name
- from category_object_map c, cr_items ci, cr_revisions r, xowiki_page p
- where c.object_id = ci.item_id and ci.parent_id = :wiki_folder_id
- and ci.content_type not in ('::xowiki::PageTemplate')
- and ci.name not in ('en:header_page','en:index','en:indexe')
- and r.revision_id = ci.live_revision
- and p.page_id = r.revision_id
- and category_id = :cat_id
- order by p.page_order} {
- ns_cache flush xotcl_object_cache ::$item_id
- ns_cache flush xotcl_object_cache ::$revision_id
-
- ::xo::db::sql::content_item set_live_revision \
- -revision_id $revision_id \
- -publish_status $state
-
- if {$state ne "production"} {
- # ::xowiki::notification::do_notifications
- # -revision_id $revision_id
- # ::xowiki::datasource $revision_id
- } else {
- db_dml flush_syndication {delete from syndication where object_id = :revision_id}
- }
- }
+ set cat_id [lindex $one_category 0]
+ db_foreach select_page {
+ select ci.item_id, r.revision_id, ci.name
+ from category_object_map c, cr_items ci, cr_revisions r, xowiki_page p
+ where c.object_id = ci.item_id and ci.parent_id = :wiki_folder_id
+ and ci.content_type not in ('::xowiki::PageTemplate')
+ and ci.name not in ('en:header_page','en:index','en:indexe')
+ and r.revision_id = ci.live_revision
+ and p.page_id = r.revision_id
+ and category_id = :cat_id
+ order by p.page_order} {
+ ns_cache flush xotcl_object_cache ::$item_id
+ ns_cache flush xotcl_object_cache ::$revision_id
+
+ ::xo::db::sql::content_item set_live_revision \
+ -revision_id $revision_id \
+ -publish_status $state
+
+ if {$state ne "production"} {
+ # ::xowiki::notification::do_notifications
+ # -revision_id $revision_id
+ # ::xowiki::datasource $revision_id
+ } else {
+ db_dml flush_syndication {delete from syndication where object_id = :revision_id}
+ }
+ }
}
}
-ad_proc -public learning_content::category::get_ready_objects {
+ad_proc -public learning_content::category::get_ready_objects {
-category_id
{-object_type ""}
{-content_type ""}
{-include_children:boolean}
} {
Returns a list of objects which are mapped to this category_id with publish_staus = ready
-
+
@param category_id CategoryID of the category we want to get the objects for
@param object_type Limit the search for objects of this object type
@param content_type Limit the search for objects of this content_type
@param include_children Include child categories' objects as well. Not yet implemented
-
+
@author malte ()
@creation-date Wed May 30 06:28:25 CEST 2007
} {
@@ -903,20 +903,20 @@
set where_clause "and i.item_id = com.object_id and i.content_type = :content_type and i.publish_status = 'ready' and i.name not in ('en:header_page','en:index','en:indexe')"
} elseif {$object_type ne ""} {
set join_clause ", acs_objects o"
- set where_clause "and o.object_id = com.object_id and o.object_type = :object_type"
+ set where_clause "and o.object_id = com.object_id and o.object_type = :object_type"
}
return [db_list get_ready_objects {}]
}
-ad_proc -public learning_content::category::get_all_objects {
+ad_proc -public learning_content::category::get_all_objects {
-category_id
{-object_type ""}
{-content_type ""}
{-show_all_p "f"}
{-include_children:boolean}
} {
Returns a list of objects which are mapped to this category_id with publish_status = ready or production
-
+
@param category_id CategoryID of the category we want to get the objects for
@param object_type Limit the search for objects of this object type
@param content_type Limit the search for objects of this content_type
@@ -930,14 +930,14 @@
set where_clause ""
if {$content_type ne ""} {
set join_clause ", cr_items i"
- if {$show_all_p} {
- set where_clause "and i.item_id = com.object_id and i.content_type = :content_type and i.publish_status in ('production','ready') and i.name not in ('en:header_page','en:index','en:indexe')"
- } else {
- set where_clause "and i.item_id = com.object_id and i.content_type = :content_type and i.publish_status = 'ready' and i.name not in ('en:header_page','en:index','en:indexe')"
- }
+ if {$show_all_p} {
+ set where_clause "and i.item_id = com.object_id and i.content_type = :content_type and i.publish_status in ('production','ready') and i.name not in ('en:header_page','en:index','en:indexe')"
+ } else {
+ set where_clause "and i.item_id = com.object_id and i.content_type = :content_type and i.publish_status = 'ready' and i.name not in ('en:header_page','en:index','en:indexe')"
+ }
} elseif {$object_type ne ""} {
set join_clause ", acs_objects o"
- set where_clause "and o.object_id = com.object_id and o.object_type = :object_type"
+ set where_clause "and o.object_id = com.object_id and o.object_type = :object_type"
}
return [db_list get_all_objects {}]
}
@@ -1085,3 +1085,9 @@
set categories [db_list get_over_categories {*SQL*}]
return $categories
}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/press/www/admin/item-create-3.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/press/www/admin/item-create-3.tcl,v
diff -u -r1.5 -r1.6
--- openacs-4/packages/press/www/admin/item-create-3.tcl 12 Feb 2019 18:00:04 -0000 1.5
+++ openacs-4/packages/press/www/admin/item-create-3.tcl 12 Feb 2019 18:45:14 -0000 1.6
@@ -9,7 +9,7 @@
@author stefan@arsdigita.com
@creation-date 2000-11-14
@cvs-id $Id$
-
+
} {
publication_name:notnull
{publication_link: ""}
@@ -36,13 +36,13 @@
set title "Confirm Sumbission"
set context [list $title]
-# with press_admin privileges, expect a release and archive date
+# with press_admin privileges, expect a release and archive date
set press_admin_p [ad_permission_p $package_id press_admin]
if { $press_admin_p == 1 && $permanent_p == "t"} {
set archive_date ""
-}
+}
# Parent root folder where press_items live
@@ -63,7 +63,7 @@
set creation_ip [ad_conn "peeraddr"]
set creation_user [ad_conn "user_id"]
-# get approval info only if the administrator
+# get approval info only if the administrator
# is creating and approving the press item in one step
if { [ad_permission_p $package_id press_admin] } {
@@ -87,7 +87,7 @@
}
# reserve empty clob for future
-# this will need to be filled in when the news module
+# this will need to be filled in when the news module
# extends this press module
set txt ""
@@ -105,11 +105,8 @@
}
-
-
-
-
-
-
-
-
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/press/www/admin/one-item-revision-add-3.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/press/www/admin/one-item-revision-add-3.tcl,v
diff -u -r1.3 -r1.4
--- openacs-4/packages/press/www/admin/one-item-revision-add-3.tcl 12 Feb 2019 18:00:04 -0000 1.3
+++ openacs-4/packages/press/www/admin/one-item-revision-add-3.tcl 12 Feb 2019 18:45:14 -0000 1.4
@@ -2,14 +2,14 @@
ad_page_contract {
- This page adds a new revision to a press item
+ This page adds a new revision to a press item
and redirects to the one-item-admin page of that item
@author stefan@arsdigita.com
@creation-date 12-1-2000
@cvs-id $Id$
-} {
+} {
item_id:integer
publication_name:notnull
{publication_link ""}
@@ -38,7 +38,7 @@
set creation_user [ad_conn "user_id"]
-# this should only be used when admin is making revision
+# this should only be used when admin is making revision
# live at time of writing...
if { [ad_permission_p $package_id press_admin] } {
@@ -73,3 +73,8 @@
ad_returnredirect "one-item-admin?item_id=$item_id"
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/simple-survey/www/process-response.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/simple-survey/www/process-response.tcl,v
diff -u -r1.7 -r1.8
--- openacs-4/packages/simple-survey/www/process-response.tcl 12 Feb 2019 18:00:04 -0000 1.7
+++ openacs-4/packages/simple-survey/www/process-response.tcl 12 Feb 2019 18:45:14 -0000 1.8
@@ -2,13 +2,13 @@
Insert user response into database.
This page receives an input for each question named
- response_to_question.$question_id
+ response_to_question.$question_id
@param survey_id survey user is responding to
@param return_url optional redirect address
- @param group_id
+ @param group_id
@param response_to_question since form variables are now named as response_to_question.$question_id, this is actually array holding user responses to all survey questions.
-
+
@author jsc@arsdigita.com
@author nstrug@arsdigita.com
@creation-date 28th September 2000
@@ -20,103 +20,103 @@
response_to_question:array,optional,multiple,html
} -validate {
-
+
survey_exists -requires { survey_id } {
- if ![db_0or1row survey_exists {
- select 1 from survsimp_surveys where survey_id = :survey_id
- }] {
- ad_complain "Survey $survey_id does not exist"
- }
+ if ![db_0or1row survey_exists {
+ select 1 from survsimp_surveys where survey_id = :survey_id
+ }] {
+ ad_complain "Survey $survey_id does not exist"
+ }
}
check_questions -requires { survey_id:integer } {
- set question_info_list [db_list_of_lists survsimp_question_info_list {
- select question_id, question_text, abstract_data_type, presentation_type, required_p
- from survsimp_questions
- where survey_id = :survey_id
- and active_p = 't'
- order by sort_key
- }]
-
- ## Validate input.
-
- set questions_with_missing_responses [list]
-
- foreach question $question_info_list {
- set question_id [lindex $question 0]
- set question_text [lindex $question 1]
- set abstract_data_type [lindex $question 2]
- set required_p [lindex $question 4]
-
- # Need to clean-up after mess with :array,multiple flags
- # in ad_page_contract. Because :multiple flag will sorround empty
- # strings and all multiword values with one level of curly braces {}
- # we need to get rid of them for almost any abstract_data_type
- # except 'choice', where this is intended behaviour. Why bother
- # with :multiple flag at all? Because otherwise we would lost all
- # but first value for 'choice' abstract_data_type - see ad_page_contract
- # doc and code for more info.
- #
- if { [exists_and_not_null response_to_question($question_id)] } {
- if {$abstract_data_type != "choice"} {
- set response_to_question($question_id) [join $response_to_question($question_id)]
- }
- }
-
-
- if { $abstract_data_type == "date" } {
- if [catch { set response_to_question($question_id) [validate_ad_dateentrywidget "" response_to_question.$question_id [ns_getform]]} errmsg] {
- ad_complain "$errmsg: Please make sure your dates are valid."
- }
- }
-
- if { [exists_and_not_null response_to_question($question_id)] } {
- set response_value [string trim $response_to_question($question_id)]
- } elseif {$required_p == "t"} {
- lappend questions_with_missing_responses $question_text
- continue
- } else {
- set response_to_question($question_id) ""
- set response_value ""
- }
-
- if {![empty_string_p $response_value]} {
- if { $abstract_data_type == "number" } {
- if { ![regexp {^(-?[0-9]+\.)?[0-9]+$} $response_value] } {
-
- ad_complain "The response to \"$question_text\" must be a number. Your answer was \"$response_value\"."
- continue
- }
- } elseif { $abstract_data_type == "integer" } {
- if { ![regexp {^[0-9]+$} $response_value] } {
-
- ad_complain "The response to \"$question_text\" must be an integer. Your answer was \"$response_value\"."
- continue
- }
- }
- }
-
- if { $abstract_data_type == "blob" } {
+ set question_info_list [db_list_of_lists survsimp_question_info_list {
+ select question_id, question_text, abstract_data_type, presentation_type, required_p
+ from survsimp_questions
+ where survey_id = :survey_id
+ and active_p = 't'
+ order by sort_key
+ }]
+
+ ## Validate input.
+
+ set questions_with_missing_responses [list]
+
+ foreach question $question_info_list {
+ set question_id [lindex $question 0]
+ set question_text [lindex $question 1]
+ set abstract_data_type [lindex $question 2]
+ set required_p [lindex $question 4]
+
+ # Need to clean-up after mess with :array,multiple flags
+ # in ad_page_contract. Because :multiple flag will sorround empty
+ # strings and all multiword values with one level of curly braces {}
+ # we need to get rid of them for almost any abstract_data_type
+ # except 'choice', where this is intended behaviour. Why bother
+ # with :multiple flag at all? Because otherwise we would lost all
+ # but first value for 'choice' abstract_data_type - see ad_page_contract
+ # doc and code for more info.
+ #
+ if { [exists_and_not_null response_to_question($question_id)] } {
+ if {$abstract_data_type != "choice"} {
+ set response_to_question($question_id) [join $response_to_question($question_id)]
+ }
+ }
+
+
+ if { $abstract_data_type == "date" } {
+ if [catch { set response_to_question($question_id) [validate_ad_dateentrywidget "" response_to_question.$question_id [ns_getform]]} errmsg] {
+ ad_complain "$errmsg: Please make sure your dates are valid."
+ }
+ }
+
+ if { [exists_and_not_null response_to_question($question_id)] } {
+ set response_value [string trim $response_to_question($question_id)]
+ } elseif {$required_p == "t"} {
+ lappend questions_with_missing_responses $question_text
+ continue
+ } else {
+ set response_to_question($question_id) ""
+ set response_value ""
+ }
+
+ if {![empty_string_p $response_value]} {
+ if { $abstract_data_type == "number" } {
+ if { ![regexp {^(-?[0-9]+\.)?[0-9]+$} $response_value] } {
+
+ ad_complain "The response to \"$question_text\" must be a number. Your answer was \"$response_value\"."
+ continue
+ }
+ } elseif { $abstract_data_type == "integer" } {
+ if { ![regexp {^[0-9]+$} $response_value] } {
+
+ ad_complain "The response to \"$question_text\" must be an integer. Your answer was \"$response_value\"."
+ continue
+ }
+ }
+ }
+
+ if { $abstract_data_type == "blob" } {
set tmp_filename $response_to_question($question_id.tmpfile)
- set n_bytes [file size $tmp_filename]
- if { $n_bytes == 0 && $required_p == "t" } {
-
- ad_complain "Your file is zero-length. Either you attempted to upload a zero length file, a file which does not exist, or something went wrong during the transfer."
- }
- }
-
- }
-
- if { [llength $questions_with_missing_responses] > 0 } {
- ad_complain "You didn't respond to all required sections. You skipped:"
- foreach skipped_question $questions_with_missing_responses {
- ad_complain $skipped_question
- }
- return 0
- } else {
- return 1
- }
+ set n_bytes [file size $tmp_filename]
+ if { $n_bytes == 0 && $required_p == "t" } {
+
+ ad_complain "Your file is zero-length. Either you attempted to upload a zero length file, a file which does not exist, or something went wrong during the transfer."
+ }
+ }
+
+ }
+
+ if { [llength $questions_with_missing_responses] > 0 } {
+ ad_complain "You didn't respond to all required sections. You skipped:"
+ foreach skipped_question $questions_with_missing_responses {
+ ad_complain $skipped_question
+ }
+ return 0
+ } else {
+ return 1
+ }
}
} -properties {
@@ -135,80 +135,80 @@
db_transaction {
db_exec_plsql create_response {
- begin
- :1 := survsimp_response.new (
- response_id => :response_id,
- survey_id => :survey_id,
- context_id => :survey_id,
- creation_user => :user_id
- );
- end;
+ begin
+ :1 := survsimp_response.new (
+ response_id => :response_id,
+ survey_id => :survey_id,
+ context_id => :survey_id,
+ creation_user => :user_id
+ );
+ end;
}
set question_info_list [db_list_of_lists survsimp_question_info_list {
select question_id, question_text, abstract_data_type, presentation_type, required_p
- from survsimp_questions
- where survey_id = :survey_id
- and active_p = 't'
- order by sort_key }]
+ from survsimp_questions
+ where survey_id = :survey_id
+ and active_p = 't'
+ order by sort_key }]
- foreach question $question_info_list {
- set question_id [lindex $question 0]
- set question_text [lindex $question 1]
- set abstract_data_type [lindex $question 2]
- set presentation_type [lindex $question 3]
+ foreach question $question_info_list {
+ set question_id [lindex $question 0]
+ set question_text [lindex $question 1]
+ set abstract_data_type [lindex $question 2]
+ set presentation_type [lindex $question 3]
- set response_value [string trim $response_to_question($question_id)]
+ set response_value [string trim $response_to_question($question_id)]
- switch -- $abstract_data_type {
- "choice" {
- if { $presentation_type == "checkbox" } {
- # Deal with multiple responses.
- set checked_responses $response_to_question($question_id)
- foreach response_value $checked_responses {
+ switch -- $abstract_data_type {
+ "choice" {
+ if { $presentation_type == "checkbox" } {
+ # Deal with multiple responses.
+ set checked_responses $response_to_question($question_id)
+ foreach response_value $checked_responses {
- db_dml survsimp_question_response_checkbox_insert "insert into survsimp_question_responses (response_id, question_id, choice_id)
- values (:response_id, :question_id, :response_value)"
- }
- } else {
+ db_dml survsimp_question_response_checkbox_insert "insert into survsimp_question_responses (response_id, question_id, choice_id)
+ values (:response_id, :question_id, :response_value)"
+ }
+ } else {
- db_dml survsimp_question_response_choice_insert "insert into survsimp_question_responses (response_id, question_id, choice_id)
- values (:response_id, :question_id, :response_value)"
- }
- }
- "shorttext" {
- db_dml survsimp_question_choice_shorttext_insert "insert into survsimp_question_responses (response_id, question_id, varchar_answer)
- values (:response_id, :question_id, :response_value)"
- }
- "boolean" {
+ db_dml survsimp_question_response_choice_insert "insert into survsimp_question_responses (response_id, question_id, choice_id)
+ values (:response_id, :question_id, :response_value)"
+ }
+ }
+ "shorttext" {
+ db_dml survsimp_question_choice_shorttext_insert "insert into survsimp_question_responses (response_id, question_id, varchar_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
+ "boolean" {
- db_dml survsimp_question_response_boolean_insert "insert into survsimp_question_responses (response_id, question_id, boolean_answer)
- values (:response_id, :question_id, :response_value)"
- }
- "number" {}
- "integer" {
+ db_dml survsimp_question_response_boolean_insert "insert into survsimp_question_responses (response_id, question_id, boolean_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
+ "number" {}
+ "integer" {
- db_dml survsimp_question_response_integer_insert "insert into survsimp_question_responses (response_id, question_id, number_answer)
- values (:response_id, :question_id, :response_value)"
- }
- "text" {
+ db_dml survsimp_question_response_integer_insert "insert into survsimp_question_responses (response_id, question_id, number_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
+ "text" {
- db_dml survsimp_question_response_text_insert "
-insert into survsimp_question_responses
-(response_id, question_id, clob_answer)
-values (:response_id, :question_id, empty_clob())
- returning clob_answer into :1" -clobs [list $response_value]
- }
- "date" {
+ db_dml survsimp_question_response_text_insert "
+ insert into survsimp_question_responses
+ (response_id, question_id, clob_answer)
+ values (:response_id, :question_id, empty_clob())
+ returning clob_answer into :1" -clobs [list $response_value]
+ }
+ "date" {
- db_dml survsimp_question_response_date_insert "insert into survsimp_question_responses (response_id, question_id, date_answer)
- values (:response_id, :question_id, :response_value)"
- }
+ db_dml survsimp_question_response_date_insert "insert into survsimp_question_responses (response_id, question_id, date_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
"blob" {
if { ![empty_string_p $response_value] } {
# this stuff only makes sense to do if we know the file exists
- set tmp_filename $response_to_question($question_id.tmpfile)
+ set tmp_filename $response_to_question($question_id.tmpfile)
set file_extension [string tolower [file extension $response_value]]
# remove the first . from the file extension
regsub {\.} $file_extension "" file_extension
@@ -217,78 +217,78 @@
set n_bytes [file size $tmp_filename]
# strip off the C:\directories... crud and just get the file name
if ![regexp {([^/\\]+)$} $response_value match client_filename] {
- # couldn't find a match
+ # couldn't find a match
set client_filename $response_value
}
if { $n_bytes == 0 } {
error "This should have been checked earlier."
} else {
- ### add content repository support
- # 1. create new content item
- # 2. create relation between user and content item
- # 3. create a new empty content revision and make live
- # 4. update the cr_revisions table with the blob data
- # 5. update the survey table
- db_transaction {
- set name "blob-response-$response_id"
+ ### add content repository support
+ # 1. create new content item
+ # 2. create relation between user and content item
+ # 3. create a new empty content revision and make live
+ # 4. update the cr_revisions table with the blob data
+ # 5. update the survey table
+ db_transaction {
+ set name "blob-response-$response_id"
- set item_id [db_exec_plsql create_item "
- begin
- :1 := content_item.new (
- name => :name,
- creation_ip => :creation_ip);
- end;"]
+ set item_id [db_exec_plsql create_item "
+ begin
+ :1 := content_item.new (
+ name => :name,
+ creation_ip => :creation_ip);
+ end;"]
- set rel_id [db_exec_plsql create_rel "
- begin
- :1 := acs_rel.new (
- rel_type => 'user_blob_response_rel',
- object_id_one => :user_id,
- object_id_two => :item_id);
- end;"]
+ set rel_id [db_exec_plsql create_rel "
+ begin
+ :1 := acs_rel.new (
+ rel_type => 'user_blob_response_rel',
+ object_id_one => :user_id,
+ object_id_two => :item_id);
+ end;"]
- set revision_id [db_exec_plsql create_revision "
- begin
- :1 := content_revision.new (
- title => 'A Blob Response',
- item_id => :item_id,
- text => 'not_important',
- mime_type => :guessed_file_type,
- creation_date => sysdate,
- creation_user => :user_id,
- creation_ip => :creation_ip);
+ set revision_id [db_exec_plsql create_revision "
+ begin
+ :1 := content_revision.new (
+ title => 'A Blob Response',
+ item_id => :item_id,
+ text => 'not_important',
+ mime_type => :guessed_file_type,
+ creation_date => sysdate,
+ creation_user => :user_id,
+ creation_ip => :creation_ip);
- update cr_items
- set live_revision = :1
- where item_id = :item_id;
-
- end;"]
+ update cr_items
+ set live_revision = :1
+ where item_id = :item_id;
- db_dml update_response "
- update cr_revisions
- set content = empty_blob()
- where revision_id = :revision_id
- returning content into :1" -blob_files [list $tmp_filename]
+ end;"]
- set content_length [cr_file_size $tmp_filename]
+ db_dml update_response "
+ update cr_revisions
+ set content = empty_blob()
+ where revision_id = :revision_id
+ returning content into :1" -blob_files [list $tmp_filename]
- db_dml survsimp_question_response_blob_insert "
- insert into survsimp_question_responses
- (response_id, question_id, item_id,
- content_length,
- attachment_file_name, attachment_file_type,
- attachment_file_extension)
- values
- (:response_id, :question_id, :item_id,
- :content_length,
- :response_value, :guessed_file_type,
- :file_extension)"
- }
- }
+ set content_length [cr_file_size $tmp_filename]
+
+ db_dml survsimp_question_response_blob_insert "
+ insert into survsimp_question_responses
+ (response_id, question_id, item_id,
+ content_length,
+ attachment_file_name, attachment_file_type,
+ attachment_file_extension)
+ values
+ (:response_id, :question_id, :item_id,
+ :content_length,
+ :response_value, :guessed_file_type,
+ :file_extension)"
+ }
+ }
}
}
- }
+ }
}
} on_error {
ad_complain "Database Error. There was an error while trying to process your response: $errmsg"
@@ -302,40 +302,40 @@
set type [db_string get_type "select type from survsimp_surveys where survey_id = :survey_id"]
switch $type {
-
+
"general" {
-
- set survey_name [db_string survsimp_name_from_id "select name from survsimp_surveys where survey_id = :survey_id" ]
- db_release_unused_handles
+ set survey_name [db_string survsimp_name_from_id "select name from survsimp_surveys where survey_id = :survey_id" ]
- if {[info exists return_url] && ![empty_string_p $return_url]} {
- ad_returnredirect "$return_url"
+ db_release_unused_handles
+
+ if {[info exists return_url] && ![empty_string_p $return_url]} {
+ ad_returnredirect "$return_url"
ad_script_abort
- } else {
+ } else {
set context [list "Response Submitted"]
- }
+ }
}
"scored" {
db_foreach get_score "select variable_name, sum(score) as sum_of_scores
- from survsimp_choice_scores, survsimp_question_responses, survsimp_variables
- where survsimp_choice_scores.choice_id = survsimp_question_responses.choice_id
- and survsimp_choice_scores.variable_id = survsimp_variables.variable_id
- and survsimp_question_responses.response_id = :response_id
- group by variable_name" {
- set sum_score($variable_name) $sum_of_scores
- }
+ from survsimp_choice_scores, survsimp_question_responses, survsimp_variables
+ where survsimp_choice_scores.choice_id = survsimp_question_responses.choice_id
+ and survsimp_choice_scores.variable_id = survsimp_variables.variable_id
+ and survsimp_question_responses.response_id = :response_id
+ group by variable_name" {
+ set sum_score($variable_name) $sum_of_scores
+ }
set logic [db_string get_logic "select logic from survsimp_logic, survsimp_logic_surveys_map
- where survsimp_logic.logic_id = survsimp_logic_surveys_map.logic_id
- and survey_id = :survey_id"]
+ where survsimp_logic.logic_id = survsimp_logic_surveys_map.logic_id
+ and survey_id = :survey_id"]
- if {[info exists return_url] && ![empty_string_p $return_url]} {
+ if {[info exists return_url] && ![empty_string_p $return_url]} {
db_release_unused_handles
- ad_returnredirect $return_url
+ ad_returnredirect $return_url
}
eval $logic
@@ -345,11 +345,17 @@
}
default {
- if {[info exists return_url] && ![empty_string_p $return_url]} {
- ad_returnredirect "$return_url"
+ if {[info exists return_url] && ![empty_string_p $return_url]} {
+ ad_returnredirect "$return_url"
ad_script_abort
- } else {
+ } else {
set context {"Response Submitted"}
- }
+ }
}
}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/simulation/tcl/template-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/simulation/tcl/template-procs.tcl,v
diff -u -r1.76 -r1.77
--- openacs-4/packages/simulation/tcl/template-procs.tcl 12 Feb 2019 18:00:04 -0000 1.76
+++ openacs-4/packages/simulation/tcl/template-procs.tcl 12 Feb 2019 18:45:14 -0000 1.77
@@ -22,16 +22,16 @@
@param operation insert, update, delete
- @param workflow_id For update/delete: The workflow to update or delete.
+ @param workflow_id For update/delete: The workflow to update or delete.
@param array For insert/update: Name of an array in the caller's namespace with attributes to insert/update.
- @param internal Set this flag if you're calling this proc from within the corresponding proc
- for a particular workflow model. Will cause this proc to not flush the cache
+ @param internal Set this flag if you're calling this proc from within the corresponding proc
+ for a particular workflow model. Will cause this proc to not flush the cache
or call workflow::definition_changed_handler, which the caller must then do.
@return workflow_id
-
+
@see workflow::edit
} {
switch $operation {
@@ -70,7 +70,7 @@
set insert_values [list]
# Handle columns in the sim_simulations table
- foreach attr {
+ foreach attr {
sim_type suggested_duration
enroll_type casting_type
enroll_start enroll_end send_start_note_date case_start case_end
@@ -127,7 +127,7 @@
}
# Handle auxiliary rows
array set aux [list]
- foreach attr {
+ foreach attr {
enrolled invited auto_enroll
} {
if { [info exists row($attr)] } {
@@ -138,7 +138,7 @@
}
}
-
+
db_transaction {
# Base row
set workflow_id [workflow::edit \
@@ -173,7 +173,7 @@
# Handled through cascading delete
}
}
-
+
# Update sim_party_sim_map table
foreach map_type { enrolled invited auto_enroll } {
if { [info exists aux($map_type)] } {
@@ -213,7 +213,7 @@
{-workflow_id:required}
{-array:required}
} {
- Return information about a simulation template. This is a wrapper around
+ Return information about a simulation template. This is a wrapper around
workflow::get, supplementing it with the columns from sim_simulation.
@param workflow_id ID of simulation template.
@@ -264,7 +264,7 @@
if { ![exists_and_not_null package_id] } {
set package_id [ad_conn package_id]
}
-
+
return [db_list_of_lists workflows {
select w.pretty_name, w.workflow_id
from workflows w,
@@ -308,7 +308,7 @@
@param parties A list of party ids to map to the role
} {
- foreach party_id $parties {
+ foreach party_id $parties {
db_dml map_group_to_role {
insert into sim_role_party_map (role_id, party_id)
values (:role_id, :party_id)
@@ -337,9 +337,9 @@
parties {$group_id1 $group_id2 ...}
users_per_case $users_per_case2
}
- }
+ }
</pre>
-} {
+} {
upvar $array roles
array set roles {}
@@ -368,7 +368,7 @@
set roles($role_id) [array get one_role]
}
}
-
+
ad_proc -public simulation::template::get_parties {
{-members:boolean}
{-workflow_id:required}
@@ -382,7 +382,7 @@
@param members Provide this switch if you want all members of
the simulation parties rather than the parties
themselves.
-
+
@return A list of party_id:s
} {
ad_assert_arg_value_in_list rel_type { enrolled invited auto_enroll }
@@ -394,7 +394,7 @@
party_approved_member_map pamm
where spsm.simulation_id = :workflow_id
and spsm.type = :rel_type
- and pamm.party_id = spsm.party_id
+ and pamm.party_id = spsm.party_id
and pamm.party_id <> pamm.member_id
}]
} else {
@@ -414,7 +414,7 @@
Associate an object with a simulation template. Succeeds if the record is added or already exists.
} {
set exists_p [db_string row_exists {
- select count(*)
+ select count(*)
from sim_workflow_object_map
where workflow_id = :template_id
and object_id = :object_id
@@ -475,8 +475,8 @@
}
}
-ad_proc -public simulation::template::enroll_user {
- {-workflow_id:required}
+ad_proc -public simulation::template::enroll_user {
+ {-workflow_id:required}
{-user_id:required}
{-simulation_array ""}
{-email ""}
@@ -486,7 +486,7 @@
Enroll a user in a simulation. Sends out an email to the user for casting type
open and group. Creates a SimPlay message notification for the user. Note: this proc
will perform a check of whether the user is already enrolled and will do nothing if
- that is the case.
+ that is the case.
@author Peter Marklund
} {
@@ -506,7 +506,7 @@
if { [empty_string_p $email] } {
acs_user::get -user_id $user_id -array user
-
+
set email $user(email)
set user_name $user(name)
}
@@ -542,7 +542,7 @@
-object_id [ad_conn package_id] \
-interval_id [notification::get_interval_id -name "instant"] \
-delivery_method_id [notification::get_delivery_method_id -name "email"]
-
+
if { $admin_p } {
# Notify admin of all activity in the workflow. In particular this includes timed out tasks.
notification::request::new \
@@ -551,7 +551,7 @@
-object_id [ad_conn package_id] \
-interval_id [notification::get_interval_id -name "instant"] \
-delivery_method_id [notification::get_delivery_method_id -name "email"]
-
+
} else {
# Sign up the user for email notification of assigned tasks
@@ -590,14 +590,14 @@
and pamm.party_id = spsm.party_id
and pamm.member_id = cu.user_id
and pamm.party_id <> pamm.member_id
- and pamm.member_id <> :admin_user_id
+ and pamm.member_id <> :admin_user_id
} {
if { [string equal $type "auto_enroll"] } {
# enroll the user automatically
lappend enroll_user_list [list $user_id $email $user_name]
} else {
# Invite the user
- lappend invite_email_list [list $email $user_name]
+ lappend invite_email_list [list $email $user_name]
}
}
# Always enroll the admin creating the simulation
@@ -623,7 +623,7 @@
# Invite users
foreach user $invite_email_list {
set email [lindex $user 0]
- set user_name [lindex $user 1]
+ set user_name [lindex $user 1]
set package_id [ad_conn package_id]
set enrollment_page_url \
@@ -649,12 +649,12 @@
from sim_simulations
where sim_type <> 'live_sim'
and case_start < current_timestamp
- }]
+ }]
foreach simulation_id $simulations_to_start {
start -workflow_id $simulation_id
- }
+ }
- # For simulations that are not live yet and have reached their send_start_note_date,
+ # For simulations that are not live yet and have reached their send_start_note_date,
# send notifications to users in simulations that have not already been emailed.
set users_to_notify [db_list_of_lists select_simulations_to_start {
select cu.user_id,
@@ -678,10 +678,10 @@
from sim_simulation_emails sse
where sse.simulation_id = ss.simulation_id
and sse.user_id = spsm.party_id
- and sse.email_type = 'reminder')
- }]
+ and sse.email_type = 'reminder')
+ }]
foreach row $users_to_notify {
- set user_id [lindex $row 0]
+ set user_id [lindex $row 0]
set email [lindex $row 1]
set user_name [lindex $row 2]
set simulation_id [lindex $row 3]
@@ -697,7 +697,7 @@
-from_addr [ad_system_owner] \
-subject $subject\
-body $body
-
+
# Record that we sent email
db_dml record_simulation_email {
insert into sim_simulation_emails
@@ -725,7 +725,7 @@
db_transaction {
# Change sim_type to live_sim
set simulation_edit(sim_type) live_sim
-
+
simulation::template::edit -workflow_id $workflow_id -array simulation_edit
simulation::template::cast -workflow_id $workflow_id
@@ -746,8 +746,8 @@
foreach user_item $enrolled_users {
set user_id [lindex $user_item 0]
set email [lindex $user_item 1]
- set user_name [lindex $user_item 2]
-
+ set user_name [lindex $user_item 2]
+
set package_id [ad_conn package_id]
set simplay_url \
[export_vars -base "[ad_url][apm_package_url_from_id $package_id]simplay/enroll" { workflow_id }]
@@ -759,7 +759,7 @@
-from_addr [ad_system_owner] \
-subject $subject\
-body $body
- }
+ }
}
ad_proc -public simulation::template::cast {
@@ -770,13 +770,13 @@
with simulation cases. Casting means creating simulation cases and mapping each enrolled user
to one role in a simulation case. This procedure expects to be called right before the simulation starts. The
procedure works for all simulation casting types (auto, group, or open) and will complete
- any casting that has already been begun (fill up roles in already created cases first).
+ any casting that has already been begun (fill up roles in already created cases first).
</p>
<p>
The algorithm
used by the proc guarantees that all enrolled users will be cast to a role in a simulation case. However,
- it does not guarantee that the target number of users per role in a case (column sim_roles.users_per_case)
+ it does not guarantee that the target number of users per role in a case (column sim_roles.users_per_case)
always will be met.
</p>
@@ -844,7 +844,7 @@
foreach group_id $one_role(parties) {
# Only create the group list once
- if { ![info exists group_members($group_id)] } {
+ if { ![info exists group_members($group_id)] } {
# Only select enrolled users from the group
set group_members($group_id) [db_list select_enrolled_group_members {
select q.member_id from
@@ -861,7 +861,7 @@
}]
}
}
- }
+ }
# We need to refill (re-initialize) the groups that should be in multiple (all) cases, so
# keep the original group member array around
array set full_group_members [array get group_members]
@@ -893,7 +893,7 @@
-full_groups_array full_group_members \
-multiple_case_groups $multiple_case_groups
}
-
+
# If there are users left to cast, create new cases for them and repeat the same
# assignment procedure as above
set case_counter [llength $current_cases]
@@ -921,49 +921,49 @@
-full_groups_array full_group_members \
-multiple_case_groups $multiple_case_groups
- # Send the notifications here manually, because
- # otherwise notifications are not sent to right people
- # since casting is incomplete before the above command
- # has run.
+ # Send the notifications here manually, because
+ # otherwise notifications are not sent to right people
+ # since casting is incomplete before the above command
+ # has run.
- db_transaction {
-
- set action_id [simulation::template::get_element \
- -workflow_id $workflow_id \
- -element initial_action_id]
-
-
- set comment ""
- set comment_mime_type "text/plain"
- set entry_id [db_string get_entry_id {
- select max(entry_id)
- from workflow_case_log
- where case_id = :case_id
- } \
- -default ""]
+ db_transaction {
- if {[empty_string_p $entry_id]} {
-
- # Insert activity log info if not found
- set extra_vars [ns_set create]
- oacs_util::vars_to_ns_set \
- -ns_set $extra_vars \
- -var_list { entry_id case_id action_id comment comment_mime_type }
-
- set entry_id [package_instantiate_object \
- -creation_user "" \
- -extra_vars $extra_vars \
- -package_name "workflow_case_log_entry" \
- "workflow_case_log_entry"]
- }
+ set action_id [simulation::template::get_element \
+ -workflow_id $workflow_id \
+ -element initial_action_id]
- workflow::case::action::notify \
- -case_id $case_id \
- -action_id $action_id \
- -entry_id $entry_id \
- -comment $comment \
- -comment_mime_type $comment_mime_type
- }
+
+ set comment ""
+ set comment_mime_type "text/plain"
+ set entry_id [db_string get_entry_id {
+ select max(entry_id)
+ from workflow_case_log
+ where case_id = :case_id
+ } \
+ -default ""]
+
+ if {[empty_string_p $entry_id]} {
+
+ # Insert activity log info if not found
+ set extra_vars [ns_set create]
+ oacs_util::vars_to_ns_set \
+ -ns_set $extra_vars \
+ -var_list { entry_id case_id action_id comment comment_mime_type }
+
+ set entry_id [package_instantiate_object \
+ -creation_user "" \
+ -extra_vars $extra_vars \
+ -package_name "workflow_case_log_entry" \
+ "workflow_case_log_entry"]
+ }
+
+ workflow::case::action::notify \
+ -case_id $case_id \
+ -action_id $action_id \
+ -entry_id $entry_id \
+ -comment $comment \
+ -comment_mime_type $comment_mime_type
+ }
}
}
@@ -1007,13 +1007,13 @@
where wcrpm.case_id = :case_id
and wcrpm.role_id = :role_id
}]
-
+
if { [expr $users_already_in_case >= $one_role(users_per_case)] } {
set n_users_to_assign 0
} else {
set n_users_to_assign [expr $one_role(users_per_case) - $users_already_in_case]
}
-
+
#ns_log Notice "simulation::template::cast_users_in_case case_id=$case_id - beginning of role loop role_id=$role_id n_users_to_assign=$n_users_to_assign group_members=[array get group_members]"
set assignees [list]
@@ -1029,10 +1029,10 @@
# 1. Get random user from users_to_cast list who fulfils either of:
# a) User is in non-multiple case group mapped to role (group_members)
# b) User is in multi case group mapped to role (group_members)
- # c) User is not in any group (users_to_cast_not_in_groups)
+ # c) User is not in any group (users_to_cast_not_in_groups)
#ns_log Notice "simulation::template::cast_users_in_case case_id=$case_id - before users_to_cast loop, users_to_cast=$users_to_cast role_group_users=$role_group_users"
foreach user_id $users_to_cast {
-
+
set cast_user_p 0
if { [lsearch $role_group_users $user_id] != -1 } {
# Case a) or b) - user is in a group mapped to the role
@@ -1081,10 +1081,10 @@
set user_id [lindex $group_members($group_id) 0]
#ns_log Notice "simulation::template::cast_users_in_case case_id=$case_id - in users to assign loop, role_id=$role_id i=$i casting already cast user_id=$user_id from multi case group $group_id"
-
+
set user_was_cast_p 1
lappend assignees $user_id
-
+
remove_user_from_casting_groups \
-user_id $user_id \
-role_groups $one_role(parties) \
@@ -1094,7 +1094,7 @@
# Remove user from users_to_cast list
set cast_list_index [lsearch -exact $users_to_cast $user_id]
- set users_to_cast [lreplace $users_to_cast $cast_list_index $cast_list_index]
+ set users_to_cast [lreplace $users_to_cast $cast_list_index $cast_list_index]
break
}
@@ -1108,7 +1108,7 @@
lappend assignees $admin_user_id
# Only cast admin once
break
- }
+ }
}
# Keep track of which users we decided to assign to the role and move on to the next one
@@ -1134,7 +1134,7 @@
} {
Remove a cast user from the groups data structure and refill and empty
multicase groups. This is an internal proc used by the casting algorithm.
-
+
@author Peter Marklund
} {
upvar $groups_array group_members
@@ -1144,10 +1144,10 @@
foreach group_id $role_groups {
set group_index [lsearch -exact $group_members($group_id) $user_id]
set group_members($group_id) [lreplace $group_members($group_id) $group_index $group_index]
-
+
# Refill the group if it's now empty and multi-case
if { [llength $group_members($group_id)] == 0 && [lsearch $multiple_case_groups $group_id] != -1 } {
- set group_members($group_id) $full_group_members($group_id)
+ set group_members($group_id) $full_group_members($group_id)
}
}
}
@@ -1179,36 +1179,36 @@
{-package_key:required}
{-object_id:required}
} {
- Create a new simulation template.
+ Create a new simulation template.
@return The workflow_id of the created simulation.
@author Peter Marklund
} {
# Wrapper for simulation::template::edit
-
+
foreach elm { pretty_name short_name sim_type suggested_duration package_key object_id } {
set row($elm) [set $elm]
}
-
+
set workflow_id [simulation::template::edit \
-operation "insert" \
-array row]
-
+
return $workflow_id
}
ad_proc -public simulation::template::generate_spec {
{-workflow_id:required}
{-workflow_handler "simulation::template"}
- {-handlers {
- roles "simulation::role"
+ {-handlers {
+ roles "simulation::role"
actions "simulation::action"
states "workflow::state::fsm"
}}
} {
Generate a spec for a workflow in array list style.
-
+
@param workflow_id The id of the workflow to generate a spec for.
@return The spec for the workflow.
@@ -1221,7 +1221,7 @@
-handlers $handlers]
simulation::template::get -workflow_id $workflow_id -array simulation
-
+
set inner_spec [lindex $spec 1]
lappend inner_spec suggested_duration $simulation(suggested_duration)
@@ -1251,7 +1251,7 @@
if { ![empty_string_p $array] } {
upvar 1 $array row
set array row
- }
+ }
return [workflow::new_from_spec \
-package_key $package_key \
@@ -1271,14 +1271,14 @@
} {
Clones an existing simulation template. The clone must belong to either a package key or an object id.
- @param object_id The id of an ACS Object indicating the scope the workflow.
+ @param object_id The id of an ACS Object indicating the scope the workflow.
Typically this will be the id of a package type or a package instance
but it could also be some other type of ACS object within a package, for example
the id of a bug in the Bug Tracker application.
@param package_key A package to which this workflow belongs
- @param array The name of an array in the caller's namespace. Values in this array will
+ @param array The name of an array in the caller's namespace. Values in this array will
override workflow attributes of the workflow being cloned.
@author Lars Pind (lars@collaboraid.biz)
@@ -1289,8 +1289,8 @@
if { ![empty_string_p $array] } {
upvar 1 $array row
set array row
- }
-
+ }
+
set workflow_id [workflow::clone \
-workflow_id $workflow_id \
-package_key $package_key \
@@ -1340,8 +1340,8 @@
@author Peter Marklund
} {
- simulation::template::get -workflow_id $workflow_id -array sim_template
-
+ simulation::template::get -workflow_id $workflow_id -array sim_template
+
foreach tab [get_wizard_tabs] {
set tab_complete_p($tab) 0
}
@@ -1353,10 +1353,10 @@
if { ![empty_string_p $sim_template(case_start)] && ![empty_string_p $sim_template(send_start_note_date)] } {
set tab_complete_p(simulation-edit) 1
}
-
+
# 2. Roles
set role_empty_count [db_string role_empty_count {
- select count(*)
+ select count(*)
from sim_roles sr,
workflow_roles wr
where sr.role_id = wr.role_id
@@ -1365,23 +1365,23 @@
}]
if { $role_empty_count == 0 } {
set tab_complete_p(map-characters) 1
- }
+ }
# 3. Tasks
# Jarkko: I took away the check because the attachments shouldn't
- # be obligatory
- set tab_complete_p(map-tasks) 1
+ # be obligatory
+ set tab_complete_p(map-tasks) 1
# 4. Participants
set num_parties [db_string num_parties { select count(*) from sim_party_sim_map where simulation_id = :workflow_id}]
if { [string equal $sim_template(enroll_type) "open"] || $num_parties > 0 } {
set tab_complete_p(simulation-participants) 1
- }
+ }
}
casting_sim {
-
+
set n_cases [db_string select_n_cases {
select count(*)
from workflow_cases
@@ -1390,10 +1390,10 @@
if { $n_cases > 0 } {
set tab_complete_p(simulation-casting-3) 1
- }
+ }
}
}
-
+
return [array get tab_complete_p]
}
@@ -1423,7 +1423,7 @@
ad_proc -public simulation::template::get_wizard_tabs {} {
Return a list with the url:s (page script names) of the pages
- in the instantiation wizard.
+ in the instantiation wizard.
@author Peter Marklund
} {
@@ -1453,7 +1453,7 @@
participants_complete "Participants completed"
simulation-casting-3 "Ready for casting"
}
-
+
set next_index 0
foreach url [get_wizard_tabs] {
if { $state_array($url) } {
@@ -1471,14 +1471,14 @@
-pretty_name:required
{-workflow_id {}}
} {
- Check if suggested pretty_name is unique.
-
+ Check if suggested pretty_name is unique.
+
@return 1 if unique, 0 if not unique.
} {
- set exists_p [db_string name_exists {
- select count(*)
- from workflows
- where package_key = 'simulation'
+ set exists_p [db_string name_exists {
+ select count(*)
+ from workflows
+ where package_key = 'simulation'
and object_id = :package_id
and pretty_name = :pretty_name
and (:workflow_id is null or workflow_id != :workflow_id)
@@ -1536,7 +1536,7 @@
} {
Return 1 if user is in a group mapped to the the given role
and 0 otherwise.
-
+
@author Peter Marklund
} {
set user_id [ad_conn user_id]
@@ -1572,26 +1572,29 @@
parent_action_id is null"] } {
return 0
}
-
+
db_foreach get_subworkflows {
- select action_id
+ select action_id
from workflow_actions
- where workflow_id = :workflow_id and
- trigger_type in ('workflow')
+ where workflow_id = :workflow_id
+ and trigger_type in ('workflow')
} {
if { ![db_string get_sub_init "
- select count(*)
+ select count(*)
from workflow_actions
where workflow_id = :workflow_id and
trigger_type = 'init' and
parent_action_id = :action_id"] } {
- set ret_val 0
- break
+ set ret_val 0
+ break
}
}
-
+
return $ret_val
}
-
-
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/sloan-bboard/www/message-delete-2.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/sloan-bboard/www/message-delete-2.tcl,v
diff -u -r1.4 -r1.5
--- openacs-4/packages/sloan-bboard/www/message-delete-2.tcl 12 Feb 2019 18:00:04 -0000 1.4
+++ openacs-4/packages/sloan-bboard/www/message-delete-2.tcl 12 Feb 2019 18:45:14 -0000 1.5
@@ -38,11 +38,11 @@
if [string eq $replies ""] {
bboard_message_set_status -message_id $message_id -forum_id $forum_id \
- -status ""
+ -status ""
} else {
db_dml bboard_delete_threads {
- delete from bboard_forum_message_map bfm
- where message_id in (select message_id
+ delete from bboard_forum_message_map bfm
+ where message_id in (select message_id
from acs_messages m
connect by prior message_id = reply_to
start with message_id = :message_id)
@@ -55,3 +55,9 @@
}
ad_returnredirect "forum?forum_id=$forum_id"
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/survey/www/process-response.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/survey/www/process-response.tcl,v
diff -u -r1.18 -r1.19
--- openacs-4/packages/survey/www/process-response.tcl 12 Feb 2019 18:00:04 -0000 1.18
+++ openacs-4/packages/survey/www/process-response.tcl 12 Feb 2019 18:45:14 -0000 1.19
@@ -2,13 +2,13 @@
Insert user response into database.
This page receives an input for each question named
- response_to_question.$question_id
+ response_to_question.$question_id
@param section_id survey user is responding to
@param return_url optional redirect address
- @param group_id
+ @param group_id
@param response_to_question since form variables are now named as response_to_question.$question_id, this is actually array holding user responses to all survey questions.
-
+
@author jsc@arsdigita.com
@author nstrug@arsdigita.com
@date 28th September 2000
@@ -24,114 +24,114 @@
} -validate {
section_exists -requires { section_id } {
- if {![db_0or1row section_exists {}]} {
- ad_complain "[_ survey.lt_Section_section_id_do]"
- }
+ if {![db_0or1row section_exists {}]} {
+ ad_complain "[_ survey.lt_Section_section_id_do]"
+ }
}
check_questions -requires { section_id } {
- set question_info_list [db_list_of_lists survey_question_info_list {
- select question_id, question_text, abstract_data_type, presentation_type, required_p
- from survey_questions
- where section_id = :section_id
- and active_p = 't'
- order by sort_order
- }]
-
- ## Validate input.
-
- set questions_with_missing_responses [list]
-
- foreach question $question_info_list {
- set question_id [lindex $question 0]
- set question_text [lindex $question 1]
- set abstract_data_type [lindex $question 2]
- set required_p [lindex $question 4]
-
- # Need to clean-up after mess with :array,multiple flags
- # in ad_page_contract. Because :multiple flag will sorround empty
- # strings and all multiword values with one level of curly braces {}
- # we need to get rid of them for almost any abstract_data_type
- # except 'choice', where this is intended behaviour. Why bother
- # with :multiple flag at all? Because otherwise we would lost all
- # but first value for 'choice' abstract_data_type - see ad_page_contract
- # doc and code for more info.
- #
- if { ([info exists response_to_question($question_id)] && $response_to_question($question_id) ne "") } {
- if {$abstract_data_type ne "choice"} {
- set response_to_question($question_id) [join $response_to_question($question_id)]
- } else {
- if { [lindex $response_to_question($question_id) 0 ] eq "" } {
- set response_to_question($question_id) ""
- }
- }
- }
-
- if { $abstract_data_type eq "date" } {
- foreach {name value} [ns_set array [ns_getform]] {
- if {[regexp "^response_to_question\[.\]$question_id\[.\](.*)\$" $name _ part]} {
- set date_value($part) $value
- }
- }
- set ok [ad_page_contract_filter_proc_date "date" date_value]
- if {$ok} {
- set response_to_question($question_id) [ns_buildsqldate $date_value(month) \
- $date_value(day) \
- $date_value(year)]
- } else {
- ad_complain "Please make sure your dates are valid."
- }
- }
-
-
- if { ([info exists response_to_question($question_id)] && $response_to_question($question_id) ne "") } {
+ set question_info_list [db_list_of_lists survey_question_info_list {
+ select question_id, question_text, abstract_data_type, presentation_type, required_p
+ from survey_questions
+ where section_id = :section_id
+ and active_p = 't'
+ order by sort_order
+ }]
- set response_value [string trim $response_to_question($question_id)]
- } elseif {$required_p == "t"} {
- lappend questions_with_missing_responses $question_text
- continue
- } else {
- set response_to_question($question_id) ""
- set response_value ""
- }
-
- if {$response_value ne ""} {
- if { $abstract_data_type eq "number" } {
- if { ![regexp {^(-?[0-9]+\.)?[0-9]+$} $response_value] } {
-
- ad_complain "[_ survey.lt_The_response_to_ques_n]"
- continue
- }
- } elseif { $abstract_data_type eq "integer" } {
- if { ![regexp {^[0-9]+$} $response_value] } {
-
- ad_complain "[_ survey.lt_The_response_to_ques_i]"
- continue
- }
- }
- }
-
- if { $abstract_data_type eq "blob" } {
+ ## Validate input.
+
+ set questions_with_missing_responses [list]
+
+ foreach question $question_info_list {
+ set question_id [lindex $question 0]
+ set question_text [lindex $question 1]
+ set abstract_data_type [lindex $question 2]
+ set required_p [lindex $question 4]
+
+ # Need to clean-up after mess with :array,multiple flags
+ # in ad_page_contract. Because :multiple flag will sorround empty
+ # strings and all multiword values with one level of curly braces {}
+ # we need to get rid of them for almost any abstract_data_type
+ # except 'choice', where this is intended behaviour. Why bother
+ # with :multiple flag at all? Because otherwise we would lost all
+ # but first value for 'choice' abstract_data_type - see ad_page_contract
+ # doc and code for more info.
+ #
+ if { ([info exists response_to_question($question_id)] && $response_to_question($question_id) ne "") } {
+ if {$abstract_data_type ne "choice"} {
+ set response_to_question($question_id) [join $response_to_question($question_id)]
+ } else {
+ if { [lindex $response_to_question($question_id) 0 ] eq "" } {
+ set response_to_question($question_id) ""
+ }
+ }
+ }
+
+ if { $abstract_data_type eq "date" } {
+ foreach {name value} [ns_set array [ns_getform]] {
+ if {[regexp "^response_to_question\[.\]$question_id\[.\](.*)\$" $name _ part]} {
+ set date_value($part) $value
+ }
+ }
+ set ok [ad_page_contract_filter_proc_date "date" date_value]
+ if {$ok} {
+ set response_to_question($question_id) [ns_buildsqldate $date_value(month) \
+ $date_value(day) \
+ $date_value(year)]
+ } else {
+ ad_complain "Please make sure your dates are valid."
+ }
+ }
+
+
+ if { ([info exists response_to_question($question_id)] && $response_to_question($question_id) ne "") } {
+
+ set response_value [string trim $response_to_question($question_id)]
+ } elseif {$required_p == "t"} {
+ lappend questions_with_missing_responses $question_text
+ continue
+ } else {
+ set response_to_question($question_id) ""
+ set response_value ""
+ }
+
+ if {$response_value ne ""} {
+ if { $abstract_data_type eq "number" } {
+ if { ![regexp {^(-?[0-9]+\.)?[0-9]+$} $response_value] } {
+
+ ad_complain "[_ survey.lt_The_response_to_ques_n]"
+ continue
+ }
+ } elseif { $abstract_data_type eq "integer" } {
+ if { ![regexp {^[0-9]+$} $response_value] } {
+
+ ad_complain "[_ survey.lt_The_response_to_ques_i]"
+ continue
+ }
+ }
+ }
+
+ if { $abstract_data_type eq "blob" } {
set tmp_filename $response_to_question($question_id.tmpfile)
- set n_bytes [file size $tmp_filename]
- if { $n_bytes == 0 && $required_p == "t" } {
-
- ad_complain "[_ survey.lt_Your_file_is_zero-len]"
- }
- }
-
- }
-
- if { [llength $questions_with_missing_responses] > 0 } {
- ad_complain "[_ survey.lt_You_didnt_respond_to_]"
- foreach skipped_question $questions_with_missing_responses {
- ad_complain $skipped_question
- }
- return 0
- } else {
- return 1
- }
+ set n_bytes [file size $tmp_filename]
+ if { $n_bytes == 0 && $required_p == "t" } {
+
+ ad_complain "[_ survey.lt_Your_file_is_zero-len]"
+ }
+ }
+
+ }
+
+ if { [llength $questions_with_missing_responses] > 0 } {
+ ad_complain "[_ survey.lt_You_didnt_respond_to_]"
+ foreach skipped_question $questions_with_missing_responses {
+ ad_complain $skipped_question
+ }
+ return 0
+ } else {
+ return 1
+ }
}
} -properties {
@@ -162,112 +162,112 @@
set creation_ip [ad_conn peeraddr]
if {$initial_response_id==0} {
- set initial_response_id ""
+ set initial_response_id ""
}
db_transaction {
- db_exec_plsql create_response {}
+ db_exec_plsql create_response {}
- set question_info_list [db_list_of_lists survey_question_info_list {
- select question_id, question_text, abstract_data_type, presentation_type, required_p
- from survey_questions
- where section_id = :section_id
- and active_p = 't'
- order by sort_order }]
+ set question_info_list [db_list_of_lists survey_question_info_list {
+ select question_id, question_text, abstract_data_type, presentation_type, required_p
+ from survey_questions
+ where section_id = :section_id
+ and active_p = 't'
+ order by sort_order }]
- foreach question $question_info_list {
- set question_id [lindex $question 0]
- set question_text [lindex $question 1]
- set abstract_data_type [lindex $question 2]
- set presentation_type [lindex $question 3]
+ foreach question $question_info_list {
+ set question_id [lindex $question 0]
+ set question_text [lindex $question 1]
+ set abstract_data_type [lindex $question 2]
+ set presentation_type [lindex $question 3]
- set response_value [string trim $response_to_question($question_id)]
+ set response_value [string trim $response_to_question($question_id)]
- switch -- $abstract_data_type {
- "choice" {
- if { $presentation_type eq "checkbox" } {
- # Deal with multiple responses.
- set checked_responses $response_to_question($question_id)
- foreach response_value $checked_responses {
+ switch -- $abstract_data_type {
+ "choice" {
+ if { $presentation_type eq "checkbox" } {
+ # Deal with multiple responses.
+ set checked_responses $response_to_question($question_id)
+ foreach response_value $checked_responses {
- db_dml survey_question_response_checkbox_insert "insert into survey_question_responses (response_id, question_id, choice_id)
- values (:response_id, :question_id, :response_value)"
- }
- } else {
+ db_dml survey_question_response_checkbox_insert "insert into survey_question_responses (response_id, question_id, choice_id)
+ values (:response_id, :question_id, :response_value)"
+ }
+ } else {
- db_dml survey_question_response_choice_insert "insert into survey_question_responses (response_id, question_id, choice_id)
- values (:response_id, :question_id, :response_value)"
- }
- }
- "shorttext" {
- db_dml survey_question_choice_shorttext_insert "insert into survey_question_responses (response_id, question_id, varchar_answer)
- values (:response_id, :question_id, :response_value)"
- }
- "boolean" {
+ db_dml survey_question_response_choice_insert "insert into survey_question_responses (response_id, question_id, choice_id)
+ values (:response_id, :question_id, :response_value)"
+ }
+ }
+ "shorttext" {
+ db_dml survey_question_choice_shorttext_insert "insert into survey_question_responses (response_id, question_id, varchar_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
+ "boolean" {
- db_dml survey_question_response_boolean_insert "insert into survey_question_responses (response_id, question_id, boolean_answer)
- values (:response_id, :question_id, :response_value)"
- }
- "integer" -
- "number" {
- db_dml survey_question_response_integer_insert "insert into survey_question_responses (response_id, question_id, number_answer)
- values (:response_id, :question_id, :response_value)"
- }
- "text" {
+ db_dml survey_question_response_boolean_insert "insert into survey_question_responses (response_id, question_id, boolean_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
+ "integer" -
+ "number" {
+ db_dml survey_question_response_integer_insert "insert into survey_question_responses (response_id, question_id, number_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
+ "text" {
- db_dml survey_question_response_text_insert "
-insert into survey_question_responses
-(response_id, question_id, clob_answer)
-values (:response_id, :question_id, empty_clob())
-returning clob_answer into :1" -clobs [list $response_value]
- }
- "date" {
+ db_dml survey_question_response_text_insert "
+ insert into survey_question_responses
+ (response_id, question_id, clob_answer)
+ values (:response_id, :question_id, empty_clob())
+ returning clob_answer into :1" -clobs [list $response_value]
+ }
+ "date" {
- db_dml survey_question_response_date_insert "insert into survey_question_responses (response_id, question_id, date_answer)
-values (:response_id, :question_id, :response_value)"
- }
- "blob" {
+ db_dml survey_question_response_date_insert "insert into survey_question_responses (response_id, question_id, date_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
+ "blob" {
- if { $response_value ne "" } {
+ if { $response_value ne "" } {
# this stuff only makes sense to do if we know the file exists
- set tmp_filename $response_to_question($question_id.tmpfile)
+ set tmp_filename $response_to_question($question_id.tmpfile)
- set file_extension [string tolower [file extension $response_value]]
- # remove the first . from the file extension
- regsub {\.} $file_extension "" file_extension
- set guessed_file_type [ns_guesstype $response_value]
+ set file_extension [string tolower [file extension $response_value]]
+ # remove the first . from the file extension
+ regsub {\.} $file_extension "" file_extension
+ set guessed_file_type [ns_guesstype $response_value]
- set n_bytes [file size $tmp_filename]
- # strip off the C:\directories... crud and just get the file name
- if {![regexp {([^/\\]+)$} $response_value match client_filename]} {
+ set n_bytes [file size $tmp_filename]
+ # strip off the C:\directories... crud and just get the file name
+ if {![regexp {([^/\\]+)$} $response_value match client_filename]} {
# couldn't find a match
- set client_filename $response_value
- }
- if { $n_bytes == 0 } {
- error "This should have been checked earlier."
- } else {
- set unique_name "${response_value}_${response_id}"
- set mime_type [ns_guesstype $client_filename]
- set revision_id [cr_import_content -title $client_filename "" $tmp_filename $n_bytes $mime_type $unique_name ]
-# we use cr_import_content now --DaveB
-# this abstracts out for use the blob handling for oracle or postgresql
-# we are linking the file item_id to the survey_question_response attachment_answer field now
+ set client_filename $response_value
+ }
+ if { $n_bytes == 0 } {
+ error "This should have been checked earlier."
+ } else {
+ set unique_name "${response_value}_${response_id}"
+ set mime_type [ns_guesstype $client_filename]
+ set revision_id [cr_import_content -title $client_filename "" $tmp_filename $n_bytes $mime_type $unique_name ]
+ # we use cr_import_content now --DaveB
+ # this abstracts out for use the blob handling for oracle or postgresql
+ # we are linking the file item_id to the survey_question_response attachment_answer field now
db_dml survey_question_response_attachment_insert "
-insert into survey_question_responses
-(response_id, question_id, attachment_answer)
-values
-(:response_id, :question_id, :revision_id
- )"
- }
+ insert into survey_question_responses
+ (response_id, question_id, attachment_answer)
+ values
+ (:response_id, :question_id, :revision_id
+ )"
+ }
+ }
}
}
- }
+ }
}
-}
-survey_do_notifications -response_id $response_id
+ survey_do_notifications -response_id $response_id
}
@@ -277,8 +277,10 @@
} else {
set context [_ survey.lt_Response_Submitted_for]
ad_return_template
-}
-
+}
-
-
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/survey/www/admin/process-response.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/survey/www/admin/process-response.tcl,v
diff -u -r1.8 -r1.9
--- openacs-4/packages/survey/www/admin/process-response.tcl 12 Feb 2019 18:00:04 -0000 1.8
+++ openacs-4/packages/survey/www/admin/process-response.tcl 12 Feb 2019 18:45:14 -0000 1.9
@@ -2,14 +2,14 @@
Insert user response into database.
This page receives an input for each question named
- response_to_question.$question_id
+ response_to_question.$question_id
Adapted from www/process-response.tcl
@param section_id survey user is responding to
@param return_url optional redirect address
- @param group_id
+ @param group_id
@param response_to_question since form variables are now named as response_to_question.$question_id, this is actually array holding user responses to all survey questions.
-
+
@param edited_response_id id of the response we are editing
@author teadams@alum.mit.edu
@date 1 April 2003
@@ -25,123 +25,123 @@
} -validate {
section_exists -requires { section_id } {
- if {![db_0or1row section_exists {}]} {
- ad_complain "Section $section_id does not exist"
- }
+ if {![db_0or1row section_exists {}]} {
+ ad_complain "Section $section_id does not exist"
+ }
}
check_questions -requires { section_id } {
- set question_info_list [db_list_of_lists survey_question_info_list {
- select question_id, question_text, abstract_data_type, presentation_type, required_p
- from survey_questions
- where section_id = :section_id
- and active_p = 't'
- order by sort_order
- }]
-
- ## Validate input.
-
- set questions_with_missing_responses [list]
+ set question_info_list [db_list_of_lists survey_question_info_list {
+ select question_id, question_text, abstract_data_type, presentation_type, required_p
+ from survey_questions
+ where section_id = :section_id
+ and active_p = 't'
+ order by sort_order
+ }]
- foreach question $question_info_list {
- set question_id [lindex $question 0]
- set question_text [lindex $question 1]
- set abstract_data_type [lindex $question 2]
- set required_p [lindex $question 4]
-
- # Need to clean-up after mess with :array,multiple flags
- # in ad_page_contract. Because :multiple flag will sorround empty
- # strings and all multiword values with one level of curly braces {}
- # we need to get rid of them for almost any abstract_data_type
- # except 'choice', where this is intended behaviour. Why bother
- # with :multiple flag at all? Because otherwise we would lost all
- # but first value for 'choice' abstract_data_type - see ad_page_contract
- # doc and code for more info.
- #
- if { ([info exists response_to_question($question_id)] && $response_to_question($question_id) ne "") } {
- if {$abstract_data_type ne "choice"} {
- set response_to_question($question_id) [join $response_to_question($question_id)]
- } else {
- if { [lindex $response_to_question($question_id) 0 ] eq "" } {
- set response_to_question($question_id) ""
- }
- }
- }
-
- if { $abstract_data_type eq "date" } {
- foreach {name value} [ns_set array [ns_getform]] {
- if {[regexp "^response_to_question\[.\]$question_id\[.\](.*)\$" $name _ part]} {
- set date_value($part) $value
- }
- }
- set ok [ad_page_contract_filter_proc_date "date" date_value]
- if {$ok} {
- set response_to_question($question_id) [ns_buildsqldate $date_value(month) \
- $date_value(day) \
- $date_value(year)]
- } else {
- ad_complain "Please make sure your dates are valid."
- }
- }
-
- if { ([info exists response_to_question($question_id)] && $response_to_question($question_id) ne "") } {
- set response_value [string trim $response_to_question($question_id)]
- } elseif {$required_p == "t"} {
-
- # When the administrator edits a survey, the file is not
- # prefilled into the form like the rest of the fields.
- # If the question is a file_upload and we are editing,
- # it is not required to enter a file. Instead, the
- # file from the prior response will be used.
+ ## Validate input.
- if { $abstract_data_type ne "blob" || $initial_response_id eq ""} {
- lappend questions_with_missing_responses $question_text
- continue
- }
-
- } else {
- set response_to_question($question_id) ""
- set response_value ""
- }
-
- if {$response_value ne ""} {
- if { $abstract_data_type eq "number" } {
- if { ![regexp {^(-?[0-9]+\.)?[0-9]+$} $response_value] } {
-
- ad_complain "The response to \"$question_text\" must be a number. Your answer was \"$response_value\"."
- continue
- }
- } elseif { $abstract_data_type eq "integer" } {
- if { ![regexp {^[0-9]+$} $response_value] } {
-
- ad_complain "The response to \"$question_text\" must be an integer. Your answer was \"$response_value\"."
- continue
- }
- }
- }
-
- if { $abstract_data_type eq "blob" } {
+ set questions_with_missing_responses [list]
+
+ foreach question $question_info_list {
+ set question_id [lindex $question 0]
+ set question_text [lindex $question 1]
+ set abstract_data_type [lindex $question 2]
+ set required_p [lindex $question 4]
+
+ # Need to clean-up after mess with :array,multiple flags
+ # in ad_page_contract. Because :multiple flag will sorround empty
+ # strings and all multiword values with one level of curly braces {}
+ # we need to get rid of them for almost any abstract_data_type
+ # except 'choice', where this is intended behaviour. Why bother
+ # with :multiple flag at all? Because otherwise we would lost all
+ # but first value for 'choice' abstract_data_type - see ad_page_contract
+ # doc and code for more info.
+ #
+ if { ([info exists response_to_question($question_id)] && $response_to_question($question_id) ne "") } {
+ if {$abstract_data_type ne "choice"} {
+ set response_to_question($question_id) [join $response_to_question($question_id)]
+ } else {
+ if { [lindex $response_to_question($question_id) 0 ] eq "" } {
+ set response_to_question($question_id) ""
+ }
+ }
+ }
+
+ if { $abstract_data_type eq "date" } {
+ foreach {name value} [ns_set array [ns_getform]] {
+ if {[regexp "^response_to_question\[.\]$question_id\[.\](.*)\$" $name _ part]} {
+ set date_value($part) $value
+ }
+ }
+ set ok [ad_page_contract_filter_proc_date "date" date_value]
+ if {$ok} {
+ set response_to_question($question_id) [ns_buildsqldate $date_value(month) \
+ $date_value(day) \
+ $date_value(year)]
+ } else {
+ ad_complain "Please make sure your dates are valid."
+ }
+ }
+
+ if { ([info exists response_to_question($question_id)] && $response_to_question($question_id) ne "") } {
+ set response_value [string trim $response_to_question($question_id)]
+ } elseif {$required_p == "t"} {
+
+ # When the administrator edits a survey, the file is not
+ # prefilled into the form like the rest of the fields.
+ # If the question is a file_upload and we are editing,
+ # it is not required to enter a file. Instead, the
+ # file from the prior response will be used.
+
+ if { $abstract_data_type ne "blob" || $initial_response_id eq ""} {
+ lappend questions_with_missing_responses $question_text
+ continue
+ }
+
+ } else {
+ set response_to_question($question_id) ""
+ set response_value ""
+ }
+
+ if {$response_value ne ""} {
+ if { $abstract_data_type eq "number" } {
+ if { ![regexp {^(-?[0-9]+\.)?[0-9]+$} $response_value] } {
+
+ ad_complain "The response to \"$question_text\" must be a number. Your answer was \"$response_value\"."
+ continue
+ }
+ } elseif { $abstract_data_type eq "integer" } {
+ if { ![regexp {^[0-9]+$} $response_value] } {
+
+ ad_complain "The response to \"$question_text\" must be an integer. Your answer was \"$response_value\"."
+ continue
+ }
+ }
+ }
+
+ if { $abstract_data_type eq "blob" } {
set tmp_filename $response_to_question($question_id.tmpfile)
- set n_bytes [file size $tmp_filename]
- if { $n_bytes == 0 && $required_p == "t" &&
- $initial_response_id eq ""} {
-
- ad_complain "Your file is zero-length. Either you attempted to upload a zero length file, a file which does not exist, or something went wrong during the transfer."
- }
- }
-
- }
-
- if { [llength $questions_with_missing_responses] > 0 } {
- ad_complain "You didn't respond to all required sections. You skipped:"
- foreach skipped_question $questions_with_missing_responses {
- ad_complain $skipped_question
- }
- return 0
- } else {
- return 1
- }
+ set n_bytes [file size $tmp_filename]
+ if { $n_bytes == 0 && $required_p == "t" &&
+ $initial_response_id eq ""} {
+
+ ad_complain "Your file is zero-length. Either you attempted to upload a zero length file, a file which does not exist, or something went wrong during the transfer."
+ }
+ }
+
+ }
+
+ if { [llength $questions_with_missing_responses] > 0 } {
+ ad_complain "You didn't respond to all required sections. You skipped:"
+ foreach skipped_question $questions_with_missing_responses {
+ ad_complain $skipped_question
+ }
+ return 0
+ } else {
+ return 1
+ }
}
} -properties {
@@ -165,17 +165,17 @@
# moved to respond.tcl for double-click protection
# set response_id [db_nextval acs_object_id_seq]
-# teadams -
+# teadams -
# From what I can tell, editing a response creates
-# a new response in the database, complete with a
+# a new response in the database, complete with a
# a response_id that is unique from the initial response.
-#
+#
# Said another way, get_response_count would return
# no rows if it were a new or edited response because
# a new id is generated in respond.tcl.
# The creator of the first version.
-#
+#
if {$initial_response_id==0} {
set initial_response_id ""
@@ -192,124 +192,126 @@
db_transaction {
- db_exec_plsql create_response {}
+ db_exec_plsql create_response {}
- set question_info_list [db_list_of_lists survey_question_info_list {
- select question_id, question_text, abstract_data_type, presentation_type, required_p
- from survey_questions
- where section_id = :section_id
- and active_p = 't'
- order by sort_order }]
+ set question_info_list [db_list_of_lists survey_question_info_list {
+ select question_id, question_text, abstract_data_type, presentation_type, required_p
+ from survey_questions
+ where section_id = :section_id
+ and active_p = 't'
+ order by sort_order }]
- foreach question $question_info_list {
- set question_id [lindex $question 0]
- set question_text [lindex $question 1]
- set abstract_data_type [lindex $question 2]
- set presentation_type [lindex $question 3]
+ foreach question $question_info_list {
+ set question_id [lindex $question 0]
+ set question_text [lindex $question 1]
+ set abstract_data_type [lindex $question 2]
+ set presentation_type [lindex $question 3]
- set response_value [string trim $response_to_question($question_id)]
+ set response_value [string trim $response_to_question($question_id)]
- switch -- $abstract_data_type {
- "choice" {
- if { $presentation_type eq "checkbox" } {
- # Deal with multiple responses.
- set checked_responses $response_to_question($question_id)
- foreach response_value $checked_responses {
+ switch -- $abstract_data_type {
+ "choice" {
+ if { $presentation_type eq "checkbox" } {
+ # Deal with multiple responses.
+ set checked_responses $response_to_question($question_id)
+ foreach response_value $checked_responses {
- db_dml survey_question_response_checkbox_insert "insert into survey_question_responses (response_id, question_id, choice_id)
- values (:response_id, :question_id, :response_value)"
- }
- } else {
+ db_dml survey_question_response_checkbox_insert "insert into survey_question_responses (response_id, question_id, choice_id)
+ values (:response_id, :question_id, :response_value)"
+ }
+ } else {
- db_dml survey_question_response_choice_insert "insert into survey_question_responses (response_id, question_id, choice_id)
- values (:response_id, :question_id, :response_value)"
- }
- }
- "shorttext" {
- db_dml survey_question_choice_shorttext_insert "insert into survey_question_responses (response_id, question_id, varchar_answer)
- values (:response_id, :question_id, :response_value)"
- }
- "boolean" {
+ db_dml survey_question_response_choice_insert "insert into survey_question_responses (response_id, question_id, choice_id)
+ values (:response_id, :question_id, :response_value)"
+ }
+ }
+ "shorttext" {
+ db_dml survey_question_choice_shorttext_insert "insert into survey_question_responses (response_id, question_id, varchar_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
+ "boolean" {
- db_dml survey_question_response_boolean_insert "insert into survey_question_responses (response_id, question_id, boolean_answer)
- values (:response_id, :question_id, :response_value)"
- }
- "integer" -
- "number" {
- db_dml survey_question_response_integer_insert "insert into survey_question_responses (response_id, question_id, number_answer)
- values (:response_id, :question_id, :response_value)"
- }
- "text" {
+ db_dml survey_question_response_boolean_insert "insert into survey_question_responses (response_id, question_id, boolean_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
+ "integer" -
+ "number" {
+ db_dml survey_question_response_integer_insert "insert into survey_question_responses (response_id, question_id, number_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
+ "text" {
- db_dml survey_question_response_text_insert "
-insert into survey_question_responses
-(response_id, question_id, clob_answer)
-values (:response_id, :question_id, empty_clob())
-returning clob_answer into :1" -clobs [list $response_value]
- }
- "date" {
+ db_dml survey_question_response_text_insert "
+ insert into survey_question_responses
+ (response_id, question_id, clob_answer)
+ values (:response_id, :question_id, empty_clob())
+ returning clob_answer into :1" -clobs [list $response_value]
+ }
+ "date" {
- db_dml survey_question_response_date_insert "insert into survey_question_responses (response_id, question_id, date_answer)
-values (:response_id, :question_id, :response_value)"
- }
- "blob" {
+ db_dml survey_question_response_date_insert "insert into survey_question_responses (response_id, question_id, date_answer)
+ values (:response_id, :question_id, :response_value)"
+ }
+ "blob" {
- if { $response_value ne "" } {
- # this stuff only makes sense to do if we know the file exists
- set tmp_filename $response_to_question($question_id.tmpfile)
+ if { $response_value ne "" } {
+ # this stuff only makes sense to do if we know the file exists
+ set tmp_filename $response_to_question($question_id.tmpfile)
- set file_extension [string tolower [file extension $response_value]]
- # remove the first . from the file extension
- regsub {\.} $file_extension "" file_extension
- set guessed_file_type [ns_guesstype $response_value]
+ set file_extension [string tolower [file extension $response_value]]
+ # remove the first . from the file extension
+ regsub {\.} $file_extension "" file_extension
+ set guessed_file_type [ns_guesstype $response_value]
- set n_bytes [file size $tmp_filename]
- # strip off the C:\directories... crud and just get the file name
- if {![regexp {([^/\\]+)$} $response_value match client_filename]} {
+ set n_bytes [file size $tmp_filename]
+ # strip off the C:\directories... crud and just get the file name
+ if {![regexp {([^/\\]+)$} $response_value match client_filename]} {
# couldn't find a match
- set client_filename $response_value
- }
- if { $n_bytes == 0 } {
- error "This should have been checked earlier."
- } else {
- set unique_name "${response_value}_${response_id}"
- set mime_type [cr_filename_to_mime_type -create $client_filename]
+ set client_filename $response_value
+ }
+ if { $n_bytes == 0 } {
+ error "This should have been checked earlier."
+ } else {
+ set unique_name "${response_value}_${response_id}"
+ set mime_type [cr_filename_to_mime_type -create $client_filename]
- set revision_id [cr_import_content -title $client_filename "" $tmp_filename $n_bytes $mime_type $unique_name ]
-# we use cr_import_content now --DaveB
-# this abstracts out for use the blob handling for oracle or postgresql
-# we are linking the file item_id to the survey_question_response attachment_answer field now
+ set revision_id [cr_import_content -title $client_filename "" $tmp_filename $n_bytes $mime_type $unique_name ]
+ # we use cr_import_content now --DaveB
+ # this abstracts out for use the blob handling for oracle or postgresql
+ # we are linking the file item_id to the survey_question_response attachment_answer field now
db_dml survey_question_response_file_attachment_insert ""
- }
- } else {
- # There was no response.
+ }
+ } else {
+ # There was no response.
- if {$initial_response_id ne ""} {
- # There was a prior response
- # Get the revision_id for this question from the
- # prior question.
-
- if {[db_0or1row survey_prior_attachment_response {}]} {
- set revision_id $attachment_answer
- db_dml survey_question_response_file_attachment_insert ""
- }
+ if {$initial_response_id ne ""} {
+ # There was a prior response
+ # Get the revision_id for this question from the
+ # prior question.
- }
-
- }
- }
- }
- }
+ if {[db_0or1row survey_prior_attachment_response {}]} {
+ set revision_id $attachment_answer
+ db_dml survey_question_response_file_attachment_insert ""
+ }
+ }
+ }
+ }
+ }
+ }
+ }
}
-}
-
if {[info exists return_url] && $return_url ne ""} {
ad_returnredirect "$return_url"
ad_script_abort
} else {
set context "Response Submitted for $survey_name"
ad_return_template
-}
-
+}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/workflow/tcl/action-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/workflow/tcl/action-procs.tcl,v
diff -u -r1.41 -r1.42
--- openacs-4/packages/workflow/tcl/action-procs.tcl 12 Feb 2019 18:00:04 -0000 1.41
+++ openacs-4/packages/workflow/tcl/action-procs.tcl 12 Feb 2019 18:45:14 -0000 1.42
@@ -1,6 +1,6 @@
ad_library {
Procedures in the workflow::action namespace.
-
+
@creation-date 9 January 2003
@author Lars Pind (lars@collaboraid.biz)
@author Peter Marklund (peter@collaboraid.biz)
@@ -10,9 +10,6 @@
namespace eval workflow::action {}
namespace eval workflow:::action::fsm {}
-
-
-
#####
#
# workflow::action namespace
@@ -48,7 +45,7 @@
@param action_id Optionally specify the ID of the new action.
- @param sort_order The number which this action should be in the sort ordering sequence.
+ @param sort_order The number which this action should be in the sort ordering sequence.
Leave blank to add action at the end. If you provide a sort_order number
which already exists, existing actions are pushed down one number.
@@ -62,19 +59,19 @@
@param edit_fields A space-separated list of the names of form fields which should be
opened for editing when this action is carried out.
- @param assigned_role The short_name of an assigned role. Users in this
- role are expected (obliged) to take
+ @param assigned_role The short_name of an assigned role. Users in this
+ role are expected (obliged) to take
the action.
- @param allowed_roles A list of role short_names or IDs. Users in these roles are
+ @param allowed_roles A list of role short_names or IDs. Users in these roles are
allowed to take the action.
-
- @param privileges Users with these privileges on the object
- treated by the workflow (i.e. a bug in the
- Bug Tracker) will be allowed to take this
+
+ @param privileges Users with these privileges on the object
+ treated by the workflow (i.e. a bug in the
+ Bug Tracker) will be allowed to take this
action.
- @param callbacks List of names of service contract implementations of callbacks for the action in
+ @param callbacks List of names of service contract implementations of callbacks for the action in
impl_owner_name.impl_name format.
@param trigger_type user, auto, message, time, init, workflow, parallel, dynamic.
@@ -84,15 +81,15 @@
@param initial_action_p Deprecated. Use this switch to indicate that this is the initial
action that will fire whenever a case of the workflow
is created. The initial action is used to determine
- the initial state of the worklow as well as any
+ the initial state of the worklow as well as any
procedures that should be executed when the case created.
@param timeout_seconds If zero, the action will automatically fire whenever it becomes enabled.
If greater than zero, the action will automatically fire x number of
seconds after the action is enabled. If empty, will never fire automatically.
- @param internal Set this flag if you're calling this proc from within the corresponding proc
- for a particular workflow model. Will cause this proc to not flush the cache
+ @param internal Set this flag if you're calling this proc from within the corresponding proc
+ for a particular workflow model. Will cause this proc to not flush the cache
or call workflow::definition_changed_handler, which the caller must then do.
@return The id of the created action
@@ -104,12 +101,12 @@
@author Peter Marklund
} {
# Wrapper for workflow::action::edit
-
+
array set row [list]
- foreach col {
+ foreach col {
initial_action_p sort_order short_name pretty_name
- pretty_past_tense edit_fields allowed_roles assigned_role
- privileges callbacks always_enabled_p description description_mime_type
+ pretty_past_tense edit_fields allowed_roles assigned_role
+ privileges callbacks always_enabled_p description description_mime_type
timeout_seconds trigger_type parent_action
} {
if { [info exists $col] } {
@@ -133,24 +130,24 @@
{-array {}}
{-internal:boolean}
{-no_complain:boolean}
- {-handlers {
- roles "workflow::role"
+ {-handlers {
+ roles "workflow::role"
actions "workflow::action"
}}
} {
- Edit an action.
+ Edit an action.
- Attributes of the array:
+ Attributes of the array:
<ul>
<li>short_name
<li>pretty_name
<li>pretty_past_tense
<li>edit_fields
- <li>description
+ <li>description
<li>description_mime_type
<li>sort_order
- <li>always_enabled_p
+ <li>always_enabled_p
<li>assigned_role
<li>timeout_seconds
<li>trigger_type
@@ -167,25 +164,25 @@
<ul>
<li>initial_action_p
</ul>
-
+
@param operation insert, update, delete
- @param action_id For update/delete: The action to update or delete.
+ @param action_id For update/delete: The action to update or delete.
For insert: Optionally specify a pre-generated action_id for the action.
@param workflow_id For update/delete: Optionally specify the workflow_id. If not specified, we will execute a query to find it.
For insert: The workflow_id of the new action.
-
+
@param array For insert/update: Name of an array in the caller's namespace with attributes to insert/update.
- @param internal Set this flag if you're calling this proc from within the corresponding proc
- for a particular workflow model. Will cause this proc to not flush the cache
+ @param internal Set this flag if you're calling this proc from within the corresponding proc
+ for a particular workflow model. Will cause this proc to not flush the cache
or call workflow::definition_changed_handler, which the caller must then do.
- @param no_complain Silently ignore extra attributes that we don't know how to handle.
-
+ @param no_complain Silently ignore extra attributes that we don't know how to handle.
+
@return action_id
-
+
@author Lars Pind (lars@collaboraid.biz)
@see workflow::action::new
@@ -240,7 +237,7 @@
# Parse column values
switch $operation {
insert - update {
- # Special-case: array entry parent_action (takes short_name) and parent_action_id (takes action_id) --
+ # Special-case: array entry parent_action (takes short_name) and parent_action_id (takes action_id) --
# DB column is parent_action_id (takes action_id_id)
if { [info exists row(parent_action)] } {
if { [info exists row(parent_action_id)] } {
@@ -271,12 +268,12 @@
set insert_names [list]
set insert_values [list]
# Handle columns in the workflow_actions table
- foreach attr {
- short_name
+ foreach attr {
+ short_name
pretty_name
pretty_past_tense
edit_fields
- description
+ description
description_mime_type
sort_order
always_enabled_p
@@ -297,7 +294,7 @@
set row(pretty_name) {}
}
}
-
+
set $varname [workflow::action::generate_short_name \
-workflow_id $workflow_id \
-pretty_name $row(pretty_name) \
@@ -341,7 +338,7 @@
}
}
}
-
+
db_transaction {
# Sort_order
switch $operation {
@@ -388,7 +385,7 @@
}
}
}
-
+
# Auxiliary rows
switch $operation {
insert - update {
@@ -403,7 +400,7 @@
}
unset missing_elm(allowed_roles)
}
-
+
# Record which privileges enable the action
if { [info exists row(privileges)] } {
db_dml delete_privileges {
@@ -415,7 +412,7 @@
}
unset missing_elm(privileges)
}
-
+
# Callbacks
if { [info exists row(callbacks)] } {
db_dml delete_callbacks {
@@ -446,14 +443,14 @@
foreach { child_short_name child_spec } $row(child_${type}) {
array unset child
array set child $child_spec
- set child(short_name) $child_short_name
+ set child(short_name) $child_short_name
set child(parent_action_id) $action_id
# string trim everything
- foreach key [array names child] {
+ foreach key [array names child] {
set child($key) [string trim $child($key)]
}
-
+
${namespace}::edit \
-internal \
-handlers $handlers \
@@ -535,7 +532,7 @@
foreach action_id [set __workflow_action_data,${workflow_id}(action_ids)] {
array set one_action [set __workflow_action_data,${workflow_id}($action_id)]
-
+
if {$one_action(short_name) eq $short_name} {
return $action_id
}
@@ -575,10 +572,10 @@
@author Peter Marklund
@author Lars Pind (lars@collaboraid.biz)
- @return The array will contain the following entries:
- workflow_id, sort_order, short_name, pretty_name,
- pretty_past_tense, assigned_role (short_name), assigned_role_id,
- always_enabled_p, trigger_type, parent_action, parent_action_id, description,
+ @return The array will contain the following entries:
+ workflow_id, sort_order, short_name, pretty_name,
+ pretty_past_tense, assigned_role (short_name), assigned_role_id,
+ always_enabled_p, trigger_type, parent_action, parent_action_id, description,
description_mime_type values for an action.
@see workflow::action::get_all_info
@@ -627,12 +624,12 @@
{-sort_order {}}
} {
Add a side-effect to an action.
-
+
@param action_id The ID of the action.
- @param name Name of service contract implementation, in the form (impl_owner_name).(impl_name),
+ @param name Name of service contract implementation, in the form (impl_owner_name).(impl_name),
for example, bug-tracker.CaptureResolutionCode
@param sort_order The sort_order for the rule. Leave blank to add to the end of the list
-
+
@author Lars Pind (lars@collaboraid.biz)
} {
@@ -668,15 +665,15 @@
} {
array set callbacks [get_from_request_cache $action_id callbacks_array]
set callback_ids [get_from_request_cache $action_id callback_ids]
-
+
# Loop over the callbacks and return the impl_names of those with a matching
# contract name
set impl_names [list]
foreach callback_id $callback_ids {
array set one_callback $callbacks($callback_id)
if {$one_callback(contract_name) eq $contract_name} {
- lappend impl_names $one_callback(impl_name)
+ lappend impl_names $one_callback(impl_name)
}
}
@@ -688,7 +685,7 @@
{-sort_order:required}
} {
Increase the sort_order of other actions, if the new sort_order is already taken.
-} {
+} {
set sort_order_taken_p [db_string select_sort_order_p {}]
if { $sort_order_taken_p } {
db_dml update_sort_order {}
@@ -700,7 +697,7 @@
{-ignore_action_id {}}
} {
Returns a list of existing action short_names in this workflow.
- Useful when you're trying to ensure a short_name is unique,
+ Useful when you're trying to ensure a short_name is unique,
or construct a new short_name that is guaranteed to be unique.
@param ignore_action_id If specified, the short_name for the given action will not be included in the result set.
@@ -723,14 +720,14 @@
{-action_id {}}
} {
Generate a unique short_name from pretty_name.
-
+
@param action_id If you pass in this, we will allow that action's short_name to be reused.
-
+
} {
set existing_short_names [workflow::action::get_existing_short_names \
-workflow_id $workflow_id \
-ignore_action_id $action_id]
-
+
if { $short_name eq "" } {
if { $pretty_name eq "" } {
error "Cannot have empty pretty_name when short_name is empty"
@@ -759,7 +756,7 @@
{-parent_action_id {}}
} {
Get the action_id's of all the actions in the workflow.
-
+
@param workflow_id The ID of the workflow
@return list of action_id's.
@@ -772,7 +769,7 @@
if { $all_p } {
return $action_data(action_ids)
}
-
+
set action_ids [list]
foreach action_id $action_data(action_ids) {
if { [workflow::action::get_element \
@@ -809,12 +806,12 @@
{-parent_action_id {}}
{-action_id {}}
} {
- Check if suggested pretty_name is unique.
-
+ Check if suggested pretty_name is unique.
+
@return 1 if unique, 0 if not unique.
} {
- set exists_p [db_string name_exists {
- select count(*)
+ set exists_p [db_string name_exists {
+ select count(*)
from workflow_actions
where workflow_id = :workflow_id
and pretty_name = :pretty_name
@@ -859,31 +856,31 @@
{-description_mime_type {}}
{-timeout_seconds {}}
} {
- Add an action to a certain FSM (Finite State Machine) workflow.
- This procedure invokes the generic workflow::action::new procedures
- and does additional inserts for FSM specific information. See the
+ Add an action to a certain FSM (Finite State Machine) workflow.
+ This procedure invokes the generic workflow::action::new procedures
+ and does additional inserts for FSM specific information. See the
parameter documentation for the proc workflow::action::new.
@return the new action_id.
@see workflow::action::fsm::edit
@author Peter Marklund
-} {
+} {
# Wrapper for workflow::action::edit
array set row [list]
- foreach col {
+ foreach col {
initial_action_p sort_order short_name pretty_name
- pretty_past_tense edit_fields allowed_roles assigned_role
- privileges callbacks always_enabled_p description description_mime_type
+ pretty_past_tense edit_fields allowed_roles assigned_role
+ privileges callbacks always_enabled_p description description_mime_type
timeout_seconds trigger_type parent_action
} {
if { [info exists $col] } {
set row($col) [set $col]
}
}
- foreach elm {
+ foreach elm {
new_state new_state_id
enabled_states assigned_states
enabled_state_ids assigned_state_ids
@@ -908,15 +905,15 @@
{-workflow_id {}}
{-array {}}
{-internal:boolean}
- {-handlers {
- roles "workflow::role"
+ {-handlers {
+ roles "workflow::role"
actions "workflow::action::fsm"
states "workflow::state::fsm"
}}
} {
- Edit an action.
+ Edit an action.
- Attributes:
+ Attributes:
<ul>
<li>new_state_id
@@ -929,20 +926,20 @@
@param operation insert, update, delete
- @param action_id For update/delete: The action to update or delete.
+ @param action_id For update/delete: The action to update or delete.
For insert: Optionally specify a pre-generated action_id for the action.
@param workflow_id For update/delete: Optionally specify the workflow_id. If not specified, we will execute a query to find it.
For insert: The workflow_id of the new action.
-
+
@param array For insert/update: Name of an array in the caller's namespace with attributes to insert/update.
- @param internal Set this flag if you're calling this proc from within the corresponding proc
- for a particular workflow model. Will cause this proc to not flush the cache
+ @param internal Set this flag if you're calling this proc from within the corresponding proc
+ for a particular workflow model. Will cause this proc to not flush the cache
or call workflow::definition_changed_handler, which the caller must then do.
@return action_id
-
+
@see workflow::action::edit
} {
switch $operation {
@@ -1001,7 +998,7 @@
set insert_values [list]
# Handle columns in the workflow_fsm_actions table
- foreach attr {
+ foreach attr {
new_state_id
} {
if { [info exists row($attr)] } {
@@ -1059,7 +1056,7 @@
# Handle auxiliary rows
array set aux [list]
- foreach attr {
+ foreach attr {
enabled_state_ids assigned_state_ids
} {
if { [info exists row($attr)] } {
@@ -1069,7 +1066,7 @@
}
}
}
-
+
db_transaction {
# Base row
set action_id [workflow::action::edit \
@@ -1118,7 +1115,7 @@
# Handled through cascading delete
}
}
-
+
# Auxiliary rows
switch $operation {
insert - update {
@@ -1131,7 +1128,7 @@
}
unset aux(enabled_state_ids)
}
-
+
# Record where the action is both enabled and assigned
if { [info exists aux(assigned_state_ids)] } {
set assigned_p "t"
@@ -1184,7 +1181,7 @@
} {
# Select the info into the upvar'ed Tcl Array
upvar $array row
-
+
workflow::action::get -action_id $action_id -array row
}
@@ -1242,18 +1239,18 @@
-element workflow_id]
}
- set currently_assigned_p [db_string enabled_p {
+ set currently_assigned_p [db_string enabled_p {
select assigned_p
from workflow_fsm_action_en_in_st
where action_id = :action_id
and state_id = :state_id
} -default {}]
- set currently_enabled_p [expr {$currently_assigned_p ne ""}]
+ set currently_enabled_p [expr {$currently_assigned_p ne ""}]
set currently_assigned_p [template::util::is_true $currently_assigned_p]
set db_assigned_p [db_boolean $assigned_p]
-
+
if { $currently_enabled_p != $enabled_p} {
if { $enabled_p } {
db_dml enabled {
@@ -1262,27 +1259,27 @@
}
} else {
db_dml disable {
- delete
- from workflow_fsm_action_en_in_st
+ delete
+ from workflow_fsm_action_en_in_st
where action_id = :action_id
and state_id = :state_id
}
}
} elseif { $currently_assigned_p != $assigned_p } {
db_dml update_assigned_p {
- update workflow_fsm_action_en_in_st
+ update workflow_fsm_action_en_in_st
set assigned_p = :db_assigned_p
where action_id = :action_id
and state_id = :state_id
}
}
-
+
workflow::definition_changed_handler -workflow_id $workflow_id
}
-
+
#####
# Private procs
#####
@@ -1302,20 +1299,20 @@
@author Lars Pind (lars@collaboraid.biz)
} {
# Initialize array with default values
- array set action {
- pretty_past_tense {}
+ array set action {
+ pretty_past_tense {}
edit_fields {}
- allowed_roles {}
- assigned_role {}
- privileges {}
- always_enabled_p f
- enabled_states {}
+ allowed_roles {}
+ assigned_role {}
+ privileges {}
+ always_enabled_p f
+ enabled_states {}
assigned_states {}
- new_state {}
+ new_state {}
trigger_type user
callbacks {}
}
-
+
# Get the info from the spec
foreach { key value } $spec {
set action($key) [string trim $value]
@@ -1359,7 +1356,7 @@
get -action_id $action_id -array row
# Get rid of elements that shouldn't go into the spec
- array unset row short_name
+ array unset row short_name
array unset row action_id
array unset row workflow_id
array unset row sort_order
@@ -1397,9 +1394,9 @@
}
# Get rid of a few defaults
- array set defaults {
+ array set defaults {
trigger_type user
- always_enabled_p f
+ always_enabled_p f
}
set spec [list]
@@ -1425,7 +1422,7 @@
if { [info exists __workflow_action_data,${workflow_id}] } {
foreach action_id [set __workflow_action_data,${workflow_id}(action_ids)] {
global __workflow_one_action,$action_id
-
+
if { [info exists __workflow_one_action,$action_id] } {
unset __workflow_one_action,$action_id
}
@@ -1450,13 +1447,13 @@
array set __workflow_action_data,${workflow_id} [workflow::action::get_all_info -workflow_id $workflow_id]
}
}
-
+
ad_proc -private workflow::action::get_from_request_cache {
action_id
{element ""}
} {
This provides some abstraction for the Workflow API cache
- and also some optimization - we only convert lists to
+ and also some optimization - we only convert lists to
arrays once per request. Should be used internally
by the workflow API only.
@@ -1548,14 +1545,14 @@
}
lappend action_ids $action_id
}
-
+
foreach action_id $action_ids {
if { ![info exists action_array_${action_id}(child_action_ids)] } {
set action_array_${action_id}(child_action_ids) [list]
set action_array_${action_id}(child_actios) [list]
}
}
-
+
# Get child states
foreach state_id [workflow::fsm::get_states -all -workflow_id $workflow_id] {
workflow::state::fsm::get -state_id $state_id -array state_array
@@ -1564,7 +1561,7 @@
lappend action_array_$state_array(parent_action_id)(child_states) $state_array(short_name)
}
}
-
+
# Build a separate array for all action callbacks of the workflow
# Columns: impl_id, impl_name, impl_owner_name, contract_name, action_id
@@ -1576,7 +1573,7 @@
lappend action_array_${action_id}(callback_ids) $callback_row(impl_id)
lappend action_array_${action_id}(callbacks_array) $callback_row(impl_id) [array get callback_row]
- }
+ }
# Build an array for all allowed roles for all actions
db_foreach action_allowed_roles {} -column_array allowed_role_row {
@@ -1585,7 +1582,7 @@
lappend action_array_${action_id}(allowed_roles) $allowed_role_row(short_name)
lappend action_array_${action_id}(allowed_role_ids) $allowed_role_row(role_id)
- # The 'allowed_roles_array' entry is an array-list, keyed by role_id, with the value being
+ # The 'allowed_roles_array' entry is an array-list, keyed by role_id, with the value being
# an array-list of the information returned by this call
lappend action_array_${action_id}(allowed_roles_array) \
[list $allowed_role_row(role_id) [array get allowed_role_row]]
@@ -1623,7 +1620,7 @@
{-parent_action_id {}}
} {
Get the action_id's of all the actions in the workflow.
-
+
@param workflow_id The ID of the workflow
@return list of action_id's.
@@ -1633,3 +1630,8 @@
return [workflow::action::get_ids -all=$all_p -workflow_id $workflow_id -parent_action_id $parent_action_id]
}
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/workflow/tcl/state-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/workflow/tcl/state-procs.tcl,v
diff -u -r1.23 -r1.24
--- openacs-4/packages/workflow/tcl/state-procs.tcl 12 Feb 2019 18:00:04 -0000 1.23
+++ openacs-4/packages/workflow/tcl/state-procs.tcl 12 Feb 2019 18:45:14 -0000 1.24
@@ -1,7 +1,7 @@
ad_library {
Procedures in the workflow::fsm::state namespace and
in its child namespaces.
-
+
@creation-date 8 January 2003
@author Lars Pind (lars@collaboraid.biz)
@author Peter Marklund (peter@collaboraid.biz)
@@ -26,31 +26,31 @@
{-parent_action {}}
} {
Creates a new state for a certain FSM (Finite State Machine) workflow.
-
+
@param workflow_id The id of the FSM workflow to add the state to
@param short_name If you leave blank, the short_name will be generated from pretty_name.
- @param pretty_name
+ @param pretty_name
@param hide_fields A space-separated list of the names of form fields which should be
hidden when in this state, because they're irrelevant in a certain state.
- @param sort_order The number which this state should be in the sort ordering sequence.
+ @param sort_order The number which this state should be in the sort ordering sequence.
Leave blank to add state at the end. If you provide a sort_order number
which already exists, existing states are pushed down one number.
-
+
@param parent_action
Which action with trigger_type 'workflow' does this state belong to.
- @param internal Set this flag if you're calling this proc from within the corresponding proc
- for a particular workflow model. Will cause this proc to not flush the cache
+ @param internal Set this flag if you're calling this proc from within the corresponding proc
+ for a particular workflow model. Will cause this proc to not flush the cache
or call workflow::definition_changed_handler, which the caller must then do.
@return ID of new state.
-
+
@author Peter Marklund
-} {
+} {
# Wrapper for workflow::state::fsm::edit
foreach elm { short_name pretty_name sort_order parent_action } {
@@ -74,9 +74,9 @@
{-no_complain:boolean}
{-handlers {}}
} {
- Edit a workflow state.
+ Edit a workflow state.
- Attributes of the array are:
+ Attributes of the array are:
<ul>
<li>short_name
@@ -89,27 +89,27 @@
@param operation insert, update, delete
- @param state_id For update/delete: The state to update or delete.
+ @param state_id For update/delete: The state to update or delete.
For insert: Optionally specify a pre-generated state_id for the state.
@param workflow_id For update/delete: Optionally specify the workflow_id. If not specified, we will execute a query to find it.
For insert: The workflow_id of the new state.
-
+
@param array For insert/update: Name of an array in the caller's namespace with attributes to insert/update.
- @param internal Set this flag if you're calling this proc from within the corresponding proc
- for a particular workflow model. Will cause this proc to not flush the cache
+ @param internal Set this flag if you're calling this proc from within the corresponding proc
+ for a particular workflow model. Will cause this proc to not flush the cache
or call workflow::definition_changed_handler, which the caller must then do.
- @param no_complain Silently ignore extra attributes that we don't know how to handle.
-
+ @param no_complain Silently ignore extra attributes that we don't know how to handle.
+
@return state_id
-
+
@see workflow::state::new
@author Peter Marklund
@author Lars Pind (lars@collaboraid.biz)
-} {
+} {
switch $operation {
update - delete {
if { $state_id eq "" } {
@@ -160,7 +160,7 @@
# Parse column values
switch $operation {
insert - update {
- # Special-case: array entry parent_action (takes short_name) and parent_action_id (takes action_id) --
+ # Special-case: array entry parent_action (takes short_name) and parent_action_id (takes action_id) --
# DB column is parent_action_id (takes action_id_id)
if { [info exists row(parent_action)] } {
if { [info exists row(parent_action_id)] } {
@@ -180,7 +180,7 @@
set insert_values [list]
# Handle columns in the workflow_fsm_states table
- foreach attr {
+ foreach attr {
short_name pretty_name hide_fields sort_order parent_action_id
} {
if { [info exists row($attr)] } {
@@ -195,7 +195,7 @@
set row(pretty_name) {}
}
}
-
+
set $varname [workflow::state::fsm::generate_short_name \
-workflow_id $workflow_id \
-pretty_name $row(pretty_name) \
@@ -235,7 +235,7 @@
}
unset row(enabled_actions)
}
-
+
# Assigend actions
if { [info exists row(assigned_actions)] } {
if { [info exists row(assigned_action_ids)] } {
@@ -252,7 +252,7 @@
# Handle auxiliary rows
array set aux [list]
- foreach attr {
+ foreach attr {
enabled_action_ids assigned_action_ids
} {
if { [info exists row($attr)] } {
@@ -262,7 +262,7 @@
}
}
}
-
+
db_transaction {
# Sort_order
switch $operation {
@@ -323,7 +323,7 @@
}
unset aux(enabled_action_ids)
}
-
+
# Record where the action is both enabled and assigned
if { [info exists aux(assigned_action_ids)] } {
set assigned_p "t"
@@ -354,7 +354,7 @@
{-sort_order:required}
} {
Increase the sort_order of other states, if the new sort_order is already taken.
-} {
+} {
set sort_order_taken_p [db_string select_sort_order_p {}]
if { $sort_order_taken_p } {
db_dml update_sort_order {}
@@ -366,7 +366,7 @@
{-ignore_state_id {}}
} {
Returns a list of existing state short_names in this workflow.
- Useful when you're trying to ensure a short_name is unique,
+ Useful when you're trying to ensure a short_name is unique,
or construct a new short_name that is guaranteed to be unique.
@param ignore_state_id If specified, the short_name for the given state will not be included in the result set.
@@ -389,14 +389,14 @@
{-state_id {}}
} {
Generate a unique short_name from pretty_name.
-
+
@param state_id If you pass in this, we will allow that state's short_name to be reused.
-
+
} {
set existing_short_names [workflow::state::fsm::get_existing_short_names \
-workflow_id $workflow_id \
-ignore_state_id $state_id]
-
+
if { $short_name eq "" } {
if { $pretty_name eq "" } {
error "Cannot have empty pretty_name when short_name is empty"
@@ -500,12 +500,12 @@
{-parent_action_id {}}
{-state_id {}}
} {
- Check if suggested pretty_name is unique.
-
+ Check if suggested pretty_name is unique.
+
@return 1 if unique, 0 if not unique.
} {
- set exists_p [db_string name_exists {
- select count(*)
+ set exists_p [db_string name_exists {
+ select count(*)
from workflow_fsm_states
where workflow_id = :workflow_id
and pretty_name = :pretty_name
@@ -526,8 +526,8 @@
{-workflow_id:required}
{-parent_action_id {}}
} {
- Get the state_id's of all the states in the workflow.
-
+ Get the state_id's of all the states in the workflow.
+
@param workflow_id The ID of the workflow
@return list of state_id's.
@@ -575,10 +575,10 @@
@author Lars Pind (lars@collaboraid.biz)
} {
# Initialize array with default values
- array set state {
- hide_fields {}
+ array set state {
+ hide_fields {}
}
-
+
# Get the info from the spec
foreach { key value } $spec {
set state($key) [string trim $value]
@@ -623,7 +623,7 @@
get -state_id $state_id -array row
# Get rid of elements that shouldn't go into the spec
- array unset row short_name
+ array unset row short_name
array unset row state_id
array unset row workflow_id
array unset row sort_order
@@ -633,7 +633,7 @@
array unset row enabled_action_ids
array unset row assigned_actions
array unset row assigned_action_ids
-
+
set spec {}
foreach name [lsort [array names row]] {
if { $row($name) ne "" } {
@@ -643,7 +643,7 @@
return $spec
}
-
+
ad_proc -private workflow::state::fsm::generate_states_spec {
{-workflow_id:required}
} {
@@ -661,7 +661,7 @@
foreach state_id [workflow::fsm::get_states -workflow_id $workflow_id] {
lappend states_list [get_element -state_id $state_id -element short_name] [generate_spec -state_id $state_id]
}
-
+
return $states_list
}
@@ -679,7 +679,7 @@
# ...
# Flush the thread global cache
- util_memoize_flush [list workflow::state::fsm::get_all_info_not_cached -workflow_id $workflow_id]
+ util_memoize_flush [list workflow::state::fsm::get_all_info_not_cached -workflow_id $workflow_id]
}
ad_proc -private workflow::state::fsm::get_all_info {
@@ -733,7 +733,7 @@
set state_id $state_row(state_id)
array set state_array_$state_id [array get state_row]
-
+
lappend state_ids $state_id
}
set state_data(state_ids) $state_ids
@@ -756,10 +756,10 @@
# 1. Get action data: trigger_type, always_enabled, hierarchy
db_foreach always_enabled_actions {
- select action_id,
- short_name,
- trigger_type,
- always_enabled_p,
+ select action_id,
+ short_name,
+ trigger_type,
+ always_enabled_p,
parent_action_id
from workflow_actions
where workflow_id = :workflow_id
@@ -787,11 +787,11 @@
}
}
}
-
+
# 2. Get action-state map
db_foreach always_enabled_actions {
- select e.action_id,
- e.state_id,
+ select e.action_id,
+ e.state_id,
e.assigned_p
from workflow_actions a,
workflow_fsm_action_en_in_st e
@@ -800,20 +800,20 @@
} {
set assigned_p_${state_id}($action_id) [template::util::is_true $assigned_p]
}
-
+
# 3. Put stuff back into the output array
foreach state_id $state_ids {
set state_array_${state_id}(enabled_action_ids) [list]
set state_array_${state_id}(enabled_actions) [list]
set state_array_${state_id}(assigned_action_ids) [list]
set state_array_${state_id}(assigned_actions) [list]
-
+
if { [info exists assigned_p_${state_id}] } {
foreach action_id [array names assigned_p_${state_id}] {
# Enabled
lappend state_array_${state_id}(enabled_action_ids) $action_id
lappend state_array_${state_id}(enabled_actions) $action_info(${action_id},short_name)
-
+
# Assigned
if { [set assigned_p_${state_id}($action_id)] } {
lappend state_array_${state_id}(assigned_action_ids) $action_id
@@ -834,3 +834,8 @@
return [array get state_data]}
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End:
Index: openacs-4/packages/workflow/tcl/workflow-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/workflow/tcl/workflow-procs.tcl,v
diff -u -r1.35 -r1.36
--- openacs-4/packages/workflow/tcl/workflow-procs.tcl 12 Feb 2019 18:00:04 -0000 1.35
+++ openacs-4/packages/workflow/tcl/workflow-procs.tcl 12 Feb 2019 18:45:14 -0000 1.36
@@ -1,6 +1,6 @@
ad_library {
Procedures in the workflow namespace.
-
+
@creation-date 8 January 2003
@author Lars Pind (lars@collaboraid.biz)
@author Peter Marklund (peter@collaboraid.biz)
@@ -34,15 +34,15 @@
@param package_key The package to which this workflow belongs
- @param object_id The id of an ACS Object indicating the scope the workflow.
+ @param object_id The id of an ACS Object indicating the scope the workflow.
Typically this will be the id of a package type or a package instance
but it could also be some other type of ACS object within a package, for example
the id of a bug in the Bug Tracker application.
@param object_type The type of objects that the workflow will be applied to. Valid values are in the
acs_object_types table. The parameter is optional and defaults to acs_object.
- @param callbacks List of names of service contract implementations of callbacks for the workflow in
+ @param callbacks List of names of service contract implementations of callbacks for the workflow in
impl_owner_name.impl_name format.
@return New workflow_id.
@@ -71,7 +71,7 @@
} {
Edit a workflow.
- Attributes of the array are:
+ Attributes of the array are:
<ul>
<li>short_name
@@ -89,23 +89,23 @@
@param operation insert, update, delete
- @param workflow_id For update/delete: The workflow to update or delete.
+ @param workflow_id For update/delete: The workflow to update or delete.
@param array For insert/update: Name of an array in the caller's namespace with attributes to insert/update.
- @param internal Set this flag if you're calling this proc from within the corresponding proc
- for a particular workflow model. Will cause this proc to not flush the cache
+ @param internal Set this flag if you're calling this proc from within the corresponding proc
+ for a particular workflow model. Will cause this proc to not flush the cache
or call workflow::definition_changed_handler, which the caller must then do.
- @param no_complain Silently ignore extra attributes that we don't know how to handle.
-
+ @param no_complain Silently ignore extra attributes that we don't know how to handle.
+
@return workflow_id
-
+
@see workflow::new
@author Peter Marklund
@author Lars Pind (lars@collaboraid.biz)
-} {
+} {
switch $operation {
update - delete {
if { $workflow_id eq "" } {
@@ -200,7 +200,7 @@
set insert_values [list]
# Handle columns in the workflows table
- foreach attr {
+ foreach attr {
short_name
pretty_name
object_id
@@ -224,7 +224,7 @@
set row(pretty_name) {}
}
}
-
+
set $varname [workflow::generate_short_name \
-workflow_id $workflow_id \
-pretty_name $row(pretty_name) \
@@ -266,7 +266,7 @@
}
}
}
-
+
db_transaction {
# Do the insert/update/delete
switch $operation {
@@ -363,7 +363,7 @@
} {
Get workflow_id by short_name and object_id. Provide either package_key
or object_id.
-
+
@param object_id The ID of the object the workflow's for (typically a package instance)
@param package_key The key of the package workflow belongs to.
@param short_name the short name of the workflow you want
@@ -392,7 +392,7 @@
@param workflow_id ID of workflow
@param array name of array in which the info will be returned
@return An array list with keys workflow_id, short_name,
- pretty_name, object_id, package_key, object_type,
+ pretty_name, object_id, package_key, object_type,
and callbacks.
} {
@@ -424,7 +424,7 @@
{-parent_action_id {}}
} {
Get the role_id's of all the roles in the workflow.
-
+
@param workflow_id The ID of the workflow
@return list of role_id's.
@@ -439,7 +439,7 @@
{-parent_action_id {}}
} {
Get the action_id's of all the actions in the workflow.
-
+
@param workflow_id The ID of the workflow
@return list of action_id's.
@@ -462,7 +462,7 @@
workflow::case::state_changed_handler \
-case_id $case_id
}
-
+
}
@@ -472,15 +472,15 @@
{-ignore_workflow_id {}}
} {
Returns a list of existing workflow short_names for this package_key and object_id.
- Useful when you're trying to ensure a short_name is unique,
+ Useful when you're trying to ensure a short_name is unique,
or construct a new short_name that is guaranteed to be unique.
@param ignore_workflow_id If specified, the short_name for the given workflow will not be included in the result set.
} {
set result [list]
db_foreach select_workflows {
- select workflow_id,
+ select workflow_id,
short_name
from workflows
where package_key = :package_key
@@ -502,16 +502,16 @@
{-workflow_id {}}
} {
Generate a unique short_name from pretty_name, or verify uniqueness of a given short_name.
-
+
@param workflow_id If you pass in this, we will allow that workflow's short_name to be reused.
- @param short_name Suggested short_name.
+ @param short_name Suggested short_name.
} {
set existing_short_names [workflow::get_existing_short_names \
-package_key $package_key \
-object_id $object_id \
-ignore_workflow_id $workflow_id]
-
+
if { $short_name eq "" } {
if { $pretty_name eq "" } {
error "Cannot have empty pretty_name when short_name is empty"
@@ -537,18 +537,18 @@
ad_proc -public workflow::generate_spec {
{-workflow_id:required}
{-workflow_handler "workflow"}
- {-handlers {
- roles workflow::role
+ {-handlers {
+ roles workflow::role
actions workflow::action
}}
} {
Generate a spec for a workflow in array list style.
Note that calling this directly with the default arguments will bomb, because workflow::action doesn't implement the required API.
-
+
@param workflow_id The id of the workflow to generate a spec for.
-
+
@param handlers An array-list with Tcl namespaces where handlers for various elements are defined.
- The keys are identical to the keys in the spec, and the namespaces are where
+ The keys are identical to the keys in the spec, and the namespaces are where
the procs to handle them are defined.
@return The spec for the workflow.
@@ -584,14 +584,14 @@
foreach { key namespace } $handlers {
set subspec [list]
-
+
foreach sub_id [${namespace}::get_ids -workflow_id $workflow_id] {
set sub_short_name [${namespace}::get_element \
-one_id $sub_id \
-element short_name]
set elm_spec [${namespace}::generate_spec -one_id $sub_id -handlers $handlers]
-
- lappend subspec $sub_short_name $elm_spec
+
+ lappend subspec $sub_short_name $elm_spec
}
lappend spec $key $subspec
}
@@ -612,14 +612,14 @@
@param pretty_name A human readable name for the workflow for use in the UI.
- @param object_id The id of an ACS Object indicating the scope the workflow.
+ @param object_id The id of an ACS Object indicating the scope the workflow.
Typically this will be the id of a package type or a package instance
but it could also be some other type of ACS object within a package, for example
the id of a bug in the Bug Tracker application.
@param package_key A package to which this workflow belongs
- @param array The name of an array in the caller's namespace. Values in this array will
+ @param array The name of an array in the caller's namespace. Values in this array will
override workflow attributes of the workflow being cloned.
@author Lars Pind (lars@collaboraid.biz)
@@ -628,12 +628,12 @@
if { $array ne "" } {
upvar 1 $array row
set array row
- }
+ }
set spec [${workflow_handler}::generate_spec \
-workflow_id $workflow_id \
-workflow_handler $workflow_handler]
-
+
set workflow_id [${workflow_handler}::new_from_spec \
-package_key $package_key \
-object_id $object_id \
@@ -649,23 +649,23 @@
{-spec:required}
{-array {}}
{-workflow_handler workflow}
- {-handlers {
- roles workflow::role
+ {-handlers {
+ roles workflow::role
actions workflow::action
}}
} {
Create a new workflow from spec. Workflows must belong to either a package key or an object id.
@param package_key A package to which this workflow belongs
- @param object_id The id of an ACS Object indicating the scope the workflow.
+ @param object_id The id of an ACS Object indicating the scope the workflow.
Typically this will be the id of a package type or a package instance
but it could also be some other type of ACS object within a package, for example
the id of a bug in the Bug Tracker application.
@param spec The workflow spec
- @param array The name of an array in the caller's namespace. Values in this array will
+ @param array The name of an array in the caller's namespace. Values in this array will
override workflow attributes of the workflow being cloned.
@return The ID of the workflow created
@@ -686,7 +686,7 @@
set short_name [lindex $spec 0]
array set workflow_array [lindex $spec 1]
-
+
# Override workflow attributes from the array
if { $array ne "" } {
upvar 1 $array row
@@ -710,7 +710,7 @@
# The lookup proc might have cached that there is no workflow
# with the short name of the workflow we have now created so
# we need to flush
- util_memoize_flush_regexp {^workflow::get_id_not_cached}
+ util_memoize_flush_regexp {^workflow::get_id_not_cached}
return $workflow_id
}
@@ -721,8 +721,8 @@
{-object_id {}}
{-spec:required}
{-workflow_handler workflow}
- {-handlers {
- roles workflow::role
+ {-handlers {
+ roles workflow::role
actions workflow::action
}}
} {
@@ -735,12 +735,12 @@
@see workflow::new
} {
# Default values
- array set workflow {
+ array set workflow {
callbacks {}
object_type {acs_object}
}
- foreach { key value } $spec {
+ foreach { key value } $spec {
set workflow($key) [string trim $value]
}
@@ -750,7 +750,7 @@
set workflow($var) [set $var]
}
}
-
+
# Pull out the extra types, roles/actions/states, so we don't try to create the workflow with them
array set aux [list]
array set counter [list]
@@ -776,7 +776,7 @@
-internal \
-operation "insert" \
-array workflow]
-
+
# Create roles/actions/states
foreach { type namespace } $handlers {
# type is 'roles', 'actions', 'states', etc.
@@ -790,10 +790,10 @@
set row(short_name) $subshort_name
# string trim everything
- foreach key [array names row] {
+ foreach key [array names row] {
set row($key) [string trim $row($key)]
}
-
+
set cmd [list ${namespace}::edit \
-internal \
-workflow_id $workflow_id \
@@ -817,7 +817,7 @@
}
}
}
-
+
return $workflow_id
}
@@ -849,7 +849,7 @@
# Flush all workflow cases from the cache. We are flushing more than needed here
# but this approach seems easier and faster than looping over a potentially big number
- # of cases mapped to the workflow in the database, only a few of which may actually be
+ # of cases mapped to the workflow in the database, only a few of which may actually be
# cached and need flushing
workflow::case::flush_cache
}
@@ -918,7 +918,7 @@
lappend callback_ids $callback_row(impl_id)
lappend callback_impl_names($callback_row(contract_name)) $callback_row(impl_name)
set callbacks_array($callback_row(impl_id)) [array get callback_row]
- }
+ }
set row(callbacks) $callbacks
set row(callback_ids) $callback_ids
@@ -933,9 +933,9 @@
{-table_name:required}
} {
By default the sort_order will be the highest current sort order plus 1.
- This reflects the order in which states and actions are added to the
+ This reflects the order in which states and actions are added to the
workflow starting with 1
-
+
@author Peter Marklund
} {
set max_sort_order [db_string max_sort_order {} -default 0]
@@ -949,12 +949,12 @@
{-sort_order {}}
} {
Add a side-effect to a workflow.
-
+
@param workflow_id The ID of the workflow.
- @param name Name of service contract implementation, in the form (impl_owner_name).(impl_name),
+ @param name Name of service contract implementation, in the form (impl_owner_name).(impl_name),
for example, bug-tracker.FormatLogTitle.
@param sort_order The sort_order for the rule. Leave blank to add to the end of the list
-
+
@author Lars Pind (lars@collaboraid.biz)
} {
db_transaction {
@@ -981,7 +981,7 @@
{-workflow_id:required}
{-contract_name:required}
} {
- Return the implementation names for a certain contract and a
+ Return the implementation names for a certain contract and a
given workflow.
@author Peter Marklund
@@ -1003,10 +1003,9 @@
Return a links to sign up for notifications.
@return A multirow with columns url, label, title
} {
-
+
}
-
#####
#
# workflow::fsm namespace
@@ -1025,14 +1024,14 @@
@param package_key A package to which this workflow belongs
- @param object_id The id of an ACS Object indicating the scope the workflow.
+ @param object_id The id of an ACS Object indicating the scope the workflow.
Typically this will be the id of a package type or a package instance
but it could also be some other type of ACS object within a package, for example
the id of a bug in the Bug Tracker application.
@param spec The workflow spec
- @param array The name of an array in the caller's namespace. Values in this array will
+ @param array The name of an array in the caller's namespace. Values in this array will
override workflow attributes of the workflow being cloned.
@return The ID of the workflow created
@@ -1043,15 +1042,15 @@
if { $array ne "" } {
upvar 1 $array row
set array row
- }
+ }
return [workflow::new_from_spec \
-package_key $package_key \
-object_id $object_id \
-spec $spec \
-array $array \
-workflow_handler "workflow::fsm" \
-handlers {
- roles workflow::role
+ roles workflow::role
actions workflow::action
states workflow::state::fsm
actions workflow::action::fsm
@@ -1066,14 +1065,14 @@
} {
Clones an existing FSM workflow. The clone must belong to either a package key or an object id.
- @param object_id The id of an ACS Object indicating the scope the workflow.
+ @param object_id The id of an ACS Object indicating the scope the workflow.
Typically this will be the id of a package type or a package instance
but it could also be some other type of ACS object within a package, for example
the id of a bug in the Bug Tracker application.
@param package_key A package to which this workflow belongs
- @param array The name of an array in the caller's namespace. Values in this array will
+ @param array The name of an array in the caller's namespace. Values in this array will
override workflow attributes of the workflow being cloned.
@author Lars Pind (lars@collaboraid.biz)
@@ -1082,7 +1081,7 @@
if { $array ne "" } {
upvar 1 $array row
set array row
- }
+ }
return [workflow::clone \
-workflow_id $workflow_id \
-package_key $package_key \
@@ -1097,13 +1096,13 @@
{-workflow_id:required}
{-workflow_handler "workflow"}
{-handlers {
- roles workflow::role
+ roles workflow::role
actions workflow::action::fsm
states workflow::state::fsm
}}
} {
Generate a spec for a workflow in array list style.
-
+
@param workflow_id The id of the workflow to generate a spec for.
@return The spec for the workflow.
@@ -1123,8 +1122,8 @@
{-workflow_id:required}
{-parent_action_id {}}
} {
- Get the state_id's of all the states in the workflow.
-
+ Get the state_id's of all the states in the workflow.
+
@param workflow_id The ID of the workflow
@return list of state_id's.
@@ -1170,12 +1169,6 @@
-internal=$internal_p]
}
-
-
-
-
-
-
#####
#
# workflow::service_contract
@@ -1213,3 +1206,9 @@
return [acs_sc::impl::get_id -owner [lindex $namev 0] -name [lindex $namev 1]]
}
+
+# Local variables:
+# mode: tcl
+# tcl-indent-level: 4
+# indent-tabs-mode: nil
+# End: