Skip to content

A
acs-tcl
Commit 57f3e57c authored by Frank Bergmann's avatar Frank Bergmann
Browse files
Options

- 5.6 update

parent 8d660cc6
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 5216 additions and 4570 deletions
tcl/application-data-link-procs.tcl 0 → 100644
View file @ 57f3e57c
This diff is collapsed.
tcl/application-data-link-procs.xql 0 → 100644
View file @ 57f3e57c
<?xml version="1.0"?>
<queryset>
<fullquery name="application_data_link::new_from.create_forward_link">
<querytext>
insert into acs_data_links (rel_id, object_id_one, object_id_two, relation_tag)
values (:forward_rel_id, :object_id, :to_object_id, :relation_tag)
</querytext>
</fullquery>
<fullquery name="application_data_link::new_to.create_backward_link">
<querytext>
insert into acs_data_links (rel_id, object_id_one, object_id_two, relation_tag)
values (:backward_rel_id, :from_object_id, :object_id, :relation_tag)
</querytext>
</fullquery>
<fullquery name="application_data_link::delete_links.linked_objects">
<querytext>
select rel_id
from acs_data_links
where (object_id_one = :object_id
or object_id_two = :object_id)
[application_data_link::relation_tag_where_clause -relation_tag $relation_tag]
</querytext>
</fullquery>
<fullquery name="application_data_link::delete_links.delete_link">
<querytext>
delete from acs_data_links
where rel_id = :rel_id
</querytext>
</fullquery>
<fullquery name="application_data_link::get.linked_objects">
<querytext>
select object_id_two
from acs_data_links
where object_id_one = :object_id
[application_data_link::relation_tag_where_clause -relation_tag $relation_tag]
order by object_id_two
</querytext>
</fullquery>
<fullquery name="application_data_link::get_linked_not_cached.linked_object">
<querytext>
select o.object_id
from acs_objects o
where o.object_type = :to_object_type
and o.object_id in (select object_id_two
from acs_data_links
where object_id_one = :from_object_id
[application_data_link::relation_tag_where_clause -relation_tag $relation_tag])
order by o.object_id
</querytext>
</fullquery>
<fullquery name="application_data_link::get_linked_content_not_cached.linked_object">
<querytext>
select i.item_id
from cr_items i
where i.content_type = :to_content_type
and i.item_id in (select object_id_two
from acs_data_links
where object_id_one = :from_object_id
[application_data_link::relation_tag_where_clause -relation_tag $relation_tag])
order by i.item_id
</querytext>
</fullquery>
<fullquery name="application_data_link::get_links_from.links_from">
<querytext>
select object_id_two
from acs_data_links,
acs_objects
$content_type_from_clause
where object_id_one = :object_id
and object_id = object_id_two
[application_data_link::relation_tag_where_clause -relation_tag $relation_tag]
$to_type_where_clause
</querytext>
</fullquery>
<partialquery name="application_data_link::get_links_from.to_type_clause">
<querytext>
and object_type = :to_type
</querytext>
</partialquery>
<partialquery name="application_data_link::get_links_from.content_type_from_clause">
<querytext>
, cr_items
</querytext>
</partialquery>
<partialquery name="application_data_link::get_links_from.content_type_where_clause">
<querytext>
and content_type = :object_type
</querytext>
</partialquery>
<fullquery name="application_data_link::delete_from_list.delete_links">
<querytext>
delete from acs_data_links where object_id_one=:object_id
and object_id_two in
([template::util::tcl_to_sql_list $link_object_id_list])
[application_data_link::relation_tag_where_clause -relation_tag $relation_tag]
</querytext>
</fullquery>
<fullquery name="application_data_link::link_exists.link_exists">
<querytext>
select 1 from acs_data_links
where object_id_one = :from_object_id
and object_id_two = :to_object_id
[application_data_link::relation_tag_where_clause -relation_tag $relation_tag]
</querytext>
</fullquery>
<fullquery name="application_data_link::scan_for_links.confirm_object_ids">
<querytext>
select object_id from acs_objects where object_id in ([template::util::tcl_to_sql_list $refs])
</querytext>
</fullquery>
<partialquery name="application_data_link::relation_tag_where_clause.where_clause">
<querytext>
and relation_tag = :relation_tag
</querytext>
</partialquery>
</queryset>
tcl/application-link-procs-oracle.xql 0 → 100644
View file @ 57f3e57c
<?xml version="1.0"?>
<queryset>
<rdbms><type>oracle</type><version>8.0</version></rdbms>
<fullquery name="application_link::new.create_forward_link">
<querytext>
begin
:1 = acs_rel.new (
rel_id => null,
rel_type => 'application_link',
object_id_one => :this_package_id,
object_id_two => :target_package_id,
context_id => :this_package_id,
creation_user => :user_id,
creation_ip => :id_addr
);
end;
</querytext>
</fullquery>
<fullquery name="application_link::new.create_backward_link">
<querytext>
begin
:1 = acs_rel.new (
rel_id => null,
rel_type => 'application_link',
object_id_one => :target_package_id,
object_id_two => :this_package_id,
context_id => :this_package_id,
creation_user => :user_id,
creation_ip => :id_addr
);
end;
</querytext>
</fullquery>
</queryset>
tcl/application-link-procs-postgresql.xql 0 → 100644
View file @ 57f3e57c
<?xml version="1.0"?>
<queryset>
<rdbms><type>postgresql</type><version>7.2</version></rdbms>
<fullquery name="application_link::new.create_forward_link">
<querytext>
select acs_rel__new (
null,
'application_link',
:this_package_id,
:target_package_id,
:this_package_id,
:user_id,
:id_addr
)
</querytext>
</fullquery>
<fullquery name="application_link::new.create_backward_link">
<querytext>
select acs_rel__new (
null,
'application_link',
:target_package_id,
:this_package_id,
:this_package_id,
:user_id,
:id_addr
)
</querytext>
</fullquery>
</queryset>
tcl/application-link-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
Procs of application linking
@author Timo Hentschel (timo@timohentschel.de)
@creation-date 2005-05-23
}
namespace eval application_link {}
ad_proc -public application_link::new {
-this_package_id:required
-target_package_id:required
} {
Create a new link between this_package_id and target_package_id.
@param this_package_id ID of the package that you want linked to the target
package.
@param target_package_id The ID of the target package.
} {
if {[catch {ad_conn user_id} user_id]} {
set user_id 0
}
if {[catch {ad_conn peeraddr} id_addr]} {
set id_addr 127.0.0.1
}
set result [db_exec_plsql create_forward_link {}]
db_exec_plsql create_backward_link {}
return $result
}
ad_proc -public application_link::delete_links {
-package_id:required
} {
Delete application links for all packages linking to the given
package_id.
@param package_id Package ID that you want application links removed
from.
} {
set rel_ids [db_list linked_packages {}]
foreach rel_id $rel_ids {
relation_remove $rel_id
}
}
ad_proc -public application_link::get {
-package_id:required
} {
Retrieves a list of package_ids for all applications linked to the
given package_id.
@return List of linked package ids.
} {
return [db_list linked_packages {}]
}
ad_proc -public application_link::get_linked {
-from_package_id:required
-to_package_key:required
} {
Gets the ID for the application linked to from_package_id and matches the
to_package_type.
@param from_package_id Object ID of linked-from application.
@param to_package_type Object type of linked-to application.
@return package_id of linked package.
} {
return [db_list linked_package {}]
}
ad_proc -private ::install::xml::action::application-link { node } {
Create an application link:
<p>&lt;application-link from-package-id=&quot;<em>from-package-id</em>&quot; to-package-id=&quot;<em>to-package-id</em>&quot;/&gt;</p>
} {
set id [apm_attribute_value -default "" $node id]
set this_package_url [apm_attribute_value \
-default "" \
$node \
this_package_url]
set target_package_url [apm_attribute_value \
-default "" \
$node \
target_package_url]
set from_package_id [apm_attribute_value -default "" $node from-package-id]
set to_package_id [apm_attribute_value -default "" $node to-package-id]
if {$this_package_url ne "" } {
set this_package_id [site_node::get_element -url $this_package_url \
-element package_id]
} elseif {$from_package_id ne "" } {
set this_package_id [install::xml::util::get_id $from_package_id]
} else {
error "application-link tag must specify either this_package_url or from-package-id"
}
if {$target_package_url ne "" } {
set target_package_id [site_node::get_element -url $target_package_url \
-element package_id]
} elseif {$to_package_id ne "" } {
set target_package_id [install::xml::util::get_id $to_package_id]
} else {
error "application-link tag must specify either target_package_url or to-package-id"
}
set link_id [application_link::new -this_package_id $this_package_id \
-target_package_id $target_package_id]
if {![string is space $id]} {
set ::install::xml::ids($id) $link_id
}
}
tcl/application-link-procs.xql 0 → 100644
View file @ 57f3e57c
<?xml version="1.0"?>
<queryset>
<fullquery name="application_link::delete_links.linked_packages">
<querytext>
select rel_id
from acs_rels
where rel_type = 'application_link'
and (object_id_one = :package_id
or object_id_two = :package_id)
</querytext>
</fullquery>
<fullquery name="application_link::get.linked_packages">
<querytext>
select object_id_two
from acs_rels
where object_id_one = :package_id
and rel_type = 'application_link'
</querytext>
</fullquery>
<fullquery name="application_link::get_linked.linked_package">
<querytext>
select p.package_id
from acs_rels r, apm_packages p
where r.object_id_one = :from_package_id
and r.object_id_two = p.package_id
and p.package_key = :to_package_key
and r.rel_type = 'application_link'
</querytext>
</fullquery>
</queryset>
tcl/base64-procs.tcl deleted 100644 → 0
View file @ 8d660cc6
# base64.tcl --
#
# Encode/Decode base64 for a string
# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems
# The decoder was done for exmh by Chris Garrigues
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id$
# Version 1.0 implemented Base64_Encode, Bae64_Decode
# Version 2.0 uses the base64 namespace
# Version 2.1 fixes various decode bugs and adds options to encode
# Version 2.2 is much faster, Tcl8.0 compatible
# Version 2.2.1 bugfixes
# Version 2.2.2 bugfixes
package require Tcl 8.2
namespace eval ::base64 {
namespace export encode decode
}
if {![catch {package require Trf 2.0}]} {
# Trf is available, so implement the functionality provided here
# in terms of calls to Trf for speed.
# ::base64::encode --
#
# Base64 encode a given string.
#
# Arguments:
# args ?-maxlen maxlen? ?-wrapchar wrapchar? string
#
# If maxlen is 0, the output is not wrapped.
#
# Results:
# A Base64 encoded version of $string, wrapped at $maxlen characters
# by $wrapchar.
proc ::base64::encode {args} {
# Set the default wrapchar and maximum line length to match the output
# of GNU uuencode 4.2. Various RFC's allow for different wrapping
# characters and wraplengths, so these may be overridden by command line
# options.
set wrapchar "\n"
set maxlen 60
if { [llength $args] == 0 } {
error "wrong # args: should be \"[lindex [info level 0] 0]\
?-maxlen maxlen? ?-wrapchar wrapchar? string\""
}
set optionStrings [list "-maxlen" "-wrapchar"]
for {set i 0} {$i < [llength $args] - 1} {incr i} {
set arg [lindex $args $i]
set index [lsearch -glob $optionStrings "${arg}*"]
if { $index == -1 } {
error "unknown option \"$arg\": must be -maxlen or -wrapchar"
}
incr i
if { $i >= [llength $args] - 1 } {
error "value for \"$arg\" missing"
}
set val [lindex $args $i]
# The name of the variable to assign the value to is extracted
# from the list of known options, all of which have an
# associated variable of the same name as the option without
# a leading "-". The [string range] command is used to strip
# of the leading "-" from the name of the option.
#
# FRINK: nocheck
set [string range [lindex $optionStrings $index] 1 end] $val
}
# [string is] requires Tcl8.2; this works with 8.0 too
if {[catch {expr {$maxlen % 2}}]} {
error "expected integer but got \"$maxlen\""
}
set string [lindex $args end]
set result [::base64 -mode encode -- $string]
set result [string map [list \n ""] $result]
if {$maxlen > 0} {
set res ""
set edge [expr {$maxlen - 1}]
while {[string length $result] > $maxlen} {
append res [string range $result 0 $edge]$wrapchar
set result [string range $result $maxlen end]
}
if {[string length $result] > 0} {
append res $result
}
set result $res
}
return $result
}
# ::base64::decode --
#
# Base64 decode a given string.
#
# Arguments:
# string The string to decode. Characters not in the base64
# alphabet are ignored (e.g., newlines)
#
# Results:
# The decoded value.
proc ::base64::decode {string} {
::base64 -mode decode -- $string
}
} else {
# Without Trf use a pure tcl implementation
namespace eval base64 {
variable base64 {}
variable base64_en {}
# We create the auxiliary array base64_tmp, it will be unset later.
set i 0
foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
a b c d e f g h i j k l m n o p q r s t u v w x y z \
0 1 2 3 4 5 6 7 8 9 + /} {
set base64_tmp($char) $i
lappend base64_en $char
incr i
}
#
# Create base64 as list: to code for instance C<->3, specify
# that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded
# ascii chars get a {}. we later use the fact that lindex on a
# non-existing index returns {}, and that [expr {} < 0] is true
#
# the last ascii char is 'z'
scan z %c len
for {set i 0} {$i <= $len} {incr i} {
set char [format %c $i]
set val {}
if {[info exists base64_tmp($char)]} {
set val $base64_tmp($char)
} else {
set val {}
}
lappend base64 $val
}
# code the character "=" as -1; used to signal end of message
scan = %c i
set base64 [lreplace $base64 $i $i -1]
# remove unneeded variables
unset base64_tmp i char len val
namespace export encode decode
}
# ::base64::encode --
#
# Base64 encode a given string.
#
# Arguments:
# args ?-maxlen maxlen? ?-wrapchar wrapchar? string
#
# If maxlen is 0, the output is not wrapped.
#
# Results:
# A Base64 encoded version of $string, wrapped at $maxlen characters
# by $wrapchar.
proc ::base64::encode {args} {
set base64_en $::base64::base64_en
# Set the default wrapchar and maximum line length to match the output
# of GNU uuencode 4.2. Various RFC's allow for different wrapping
# characters and wraplengths, so these may be overridden by command line
# options.
set wrapchar "\n"
set maxlen 60
if { [llength $args] == 0 } {
error "wrong # args: should be \"[lindex [info level 0] 0]\
?-maxlen maxlen? ?-wrapchar wrapchar? string\""
}
set optionStrings [list "-maxlen" "-wrapchar"]
for {set i 0} {$i < [llength $args] - 1} {incr i} {
set arg [lindex $args $i]
set index [lsearch -glob $optionStrings "${arg}*"]
if { $index == -1 } {
error "unknown option \"$arg\": must be -maxlen or -wrapchar"
}
incr i
if { $i >= [llength $args] - 1 } {
error "value for \"$arg\" missing"
}
set val [lindex $args $i]
# The name of the variable to assign the value to is extracted
# from the list of known options, all of which have an
# associated variable of the same name as the option without
# a leading "-". The [string range] command is used to strip
# of the leading "-" from the name of the option.
#
# FRINK: nocheck
set [string range [lindex $optionStrings $index] 1 end] $val
}
# [string is] requires Tcl8.2; this works with 8.0 too
if {[catch {expr {$maxlen % 2}}]} {
error "expected integer but got \"$maxlen\""
}
set string [lindex $args end]
set result {}
set state 0
set length 0
# Process the input bytes 3-by-3
binary scan $string c* X
foreach {x y z} $X {
# Do the line length check before appending so that we don't get an
# extra newline if the output is a multiple of $maxlen chars long.
if {$maxlen && $length >= $maxlen} {
append result $wrapchar
set length 0
}
append result [lindex $base64_en [expr {($x >>2) & 0x3F}]]
if {$y != {}} {
append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]]
if {$z != {}} {
append result \
[lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]]
append result [lindex $base64_en [expr {($z & 0x3F)}]]
} else {
set state 2
break
}
} else {
set state 1
break
}
incr length 4
}
if {$state == 1} {
append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]==
} elseif {$state == 2} {
append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]=
}
return $result
}
# ::base64::decode --
#
# Base64 decode a given string.
#
# Arguments:
# string The string to decode. Characters not in the base64
# alphabet are ignored (e.g., newlines)
#
# Results:
# The decoded value.
proc ::base64::decode {string} {
if {[string length $string] == 0} {return ""}
set base64 $::base64::base64
binary scan $string c* X
foreach x $X {
set bits [lindex $base64 $x]
if {$bits >= 0} {
if {[llength [lappend nums $bits]] == 4} {
foreach {v w z y} $nums break
set a [expr {($v << 2) | ($w >> 4)}]
set b [expr {(($w & 0xF) << 4) | ($z >> 2)}]
set c [expr {(($z & 0x3) << 6) | $y}]
append output [binary format ccc $a $b $c]
set nums {}
}
} elseif {$bits == -1} {
# = indicates end of data. Output whatever chars are left.
# The encoding algorithm dictates that we can only have 1 or 2
# padding characters. If x=={}, we have 12 bits of input
# (enough for 1 8-bit output). If x!={}, we have 18 bits of
# input (enough for 2 8-bit outputs).
foreach {v w z} $nums break
set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
if {$z == {}} {
append output [binary format c $a ]
} else {
set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}]
append output [binary format cc $a $b]
}
break
} else {
# RFC 2045 says that line breaks and other characters not part
# of the Base64 alphabet must be ignored, and that the decoder
# can optionally emit a warning or reject the message. We opt
# not to do so, but to just ignore the character.
continue
}
}
return $output
}
}
package provide base64 2.2.2
tcl/callback-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
Supports the use of callbacks.
@author Lee Denison (lee@xarg.co.uk)
}
namespace eval callback {}
ad_proc -public callback::impl_exists {
{-callback:required}
{-impl:required}
} {
Returns whether the specified implementation exists.
} {
return [expr {![string equal \
[info commands ::callback::${callback}::impl::${impl}] \
""]}]
}
ad_proc -public callback::get_object_type_impl {
{-object_type:required}
{-callback:required}
} {
Finds the most type specific implementation of <code>callback</code>.
} {
if {[callback::impl_exists -callback $callback -impl $object_type]} {
return $object_type
} else {
set supertypes [acs_object_type::supertypes \
-subtype $object_type]
foreach type $supertypes {
if {[callback::impl_exists -callback $callback -impl $type]} {
return $type
}
}
}
return ""
}
tcl/ds-stub-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
Stub procs for developer support procs we call in acs-tcl
for logging. We check here if the procs are defined
before we stub them out.
This is done since the old ad_call_proc_if_exists
is somewhat expensive and these are called a lot in
every request.
@author Jeff Davis <davis@xarg.net>
@creationd-date 2005-03-02
@cvs-id $Id$
}
if {{} eq [info procs ds_add]} {
proc ds_add {args} {}
}
if {{} eq [info procs ds_collect_db_call]} {
proc ds_collect_db_call {args} {}
}
if {{} eq [info procs ds_collect_connection_info]} {
proc ds_collect_connection_info {} {}
}
tcl/http-auth-procs.tcl 0 → 100644
View file @ 57f3e57c
# packages/acs-tcl/tcl/http-auth-procs.tcl
ad_library {
Use openacs user logins for HTTP authentication
}
namespace eval http_auth {}
ad_proc http_auth::set_user_id {} {
Get the user_id from HTTP authentication headers.
NOTE: This should be handled through SSL since plain
HTTP auth is easy to decode
} {
# should be something like "Basic 29234k3j49a"
set a [ns_set get [ns_conn headers] Authorization]
if {[string length $a]} {
ns_log debug "\nTDAV auth_check authentication info $a"
# get the second bit, the base64 encoded bit
set up [lindex [split $a " "] 1]
# after decoding, it should be user:password; get the username
set user [lindex [split [ns_uudecode $up] ":"] 0]
set password [lindex [split [ns_uudecode $up] ":"] 1]
ns_log debug "\nACS VERSION [ad_acs_version]"
ns_log debug "\nHTTP authentication"
# check all authorities
foreach authority [auth::authority::get_authority_options] {
set authority_id [lindex $authority 1]
array set auth [auth::authenticate \
-username $user \
-password $password \
-authority_id $authority_id \
-no_cookie]
if {$auth(auth_status) ne "ok" } {
array set auth [auth::authenticate \
-email $user \
-password $password \
-authority_id $authority_id \
-no_cookie]
}
if {$auth(auth_status) eq "ok"} {
# we can stop checking
break
}
}
if {$auth(auth_status) ne "ok" } {
ns_log debug "\nTDAV 5.0 auth status $auth(auth_status)"
ns_returnunauthorized
return 0
}
ns_log debug "\nTDAV: auth_check openacs 5.0 user_id= $auth(user_id)"
ad_conn -set user_id $auth(user_id)
} else {
# no authenticate header, anonymous visitor
ad_conn -set user_id 0
ad_conn -set untrusted_user_id 0
}
}
ad_proc http_auth::register_filter {
-url_pattern
{-proc ""}
} {
Setup HTTP authentication for a URL pattern
@param url_pattern Follows ns_register_filter rules for defining the
pattern to match.
@param proc Name of tcl procedure to call to check permissions. Use this to figure out what object the URL pattern matches to. This proc should accept two named parameters user_id and url. Should return a valid Tcl true or false value. If empty the site_node matching the URL will be checked.
@return Tcl true or false
@author Dave Bauer (dave@solutiongrove.com)
@creation-date 2007-03-08
} {
ad_register_filter preauth GET $url_pattern http_auth::authorize $proc
ad_register_filter preauth POST $url_pattern http_auth::authorize $proc
ad_register_filter preauth HEAD $url_pattern http_auth::authorize $proc
}
ad_proc http_auth::authorize {
conn
args
why
} {
Check HTTP authentication for an openacs user account and
call the registered procedure to handle the URL to check
permissions
} {
set user_id [http_auth::set_user_id]
set proc [lindex $args 0]
if {$proc eq {}} {
set proc http_auth::site_node_authorize
}
return [eval [list $proc -user_id $user_id -url [ns_conn url]]]
}
ad_proc http_auth::site_node_authorize {
-user_id
-url
} {
Procedure to take HTTP authenticated user_id and check site_node
permissions. Default if http auth is proc is not specified.
} {
set node_id [site_node::get_element -element node_id -url $url]
if {[permission::permission_p \
-party_id $user_id \
-privilege read \
-object_id $node_id]} {
return filter_ok
}
ns_returnunauthorized
return filter_return
}
tcl/install-procs.tcl 0 → 100644
View file @ 57f3e57c
This diff is collapsed.
tcl/json-procs.tcl 0 → 100644
View file @ 57f3e57c
This diff is collapsed.
tcl/md5-procs.tcl deleted 100644 → 0
View file @ 8d660cc6
This diff is collapsed.
tcl/mime-procs.tcl deleted 100644 → 0
View file @ 8d660cc6
This diff is collapsed.
tcl/navigation-callback-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
Callback contract definitions for page rendering.
Typically the callbacks also have a corresponing
.adp for rendering their output, see the specific callbacks
for details.
@author Jeff Davis (davis@xarg.net)
@creation-date 2005-03-11
@cvs-id $Id$
}
ad_proc -public -callback navigation::package_admin {
-package_id
-user_id
{-return_url {}}
} {
<p>Returns the list of available admin actions for the passed in
user on the passed in package_id.</p>
<pre>
{
{LINK url_stub text title_text long_text}
{SECTION title long_text}
}
</pre>
<p>Where LINK and SECTION are the literal strings.</p>
<p>For LINK the url and text are required, text and title should be plain text
but long_text should be html (and renderers should present it noquote).</p>
<p>For SECTION both title and long_text can be blank which for the
rendering agent would imply a section break with something like
blank space or an &lt;hr&gt; tag. Also keep in mind the rendering
agent may be creating dropdown menus which would only display the
link text and title or might be rendering in a page in which case
all things might be rendered so try to make sure the short "title"
and "text" fields are not abiguous. heading should be plain text
but long_text is treated as html.
</p>
<p><b>url_stub</b> should be relative to the package mountpoint
and without a leading / since the link may be prefixed by the
full path or by the vhost url depending on context.</p>
<p>The <code>/packages/acs-tcl/lib/actions.adp<code> file is an include which
will render admin actions returned by this callback.</p>
@param package_id - the package for which to generate the admin links
@param user_id - the user_id for whom the list should be generated
@param return_url - a return_url provided by the rendering agent
for those actions which could come back
@return a list with one element, the list of actions
{{{LINK url_stub text title_text long_text} ... }}
@see callback::package::admin_actions::impl::forums
@see /packages/acs-tcl/lib/actions.adp
@see /packages/acs-tcl/lib/actions.tcl
@author Jeff Davis (davis@xarg.net)
} -
tcl/parameter-procs.xql 0 → 100644
View file @ 57f3e57c
<?xml version="1.0"?>
<queryset>
<fullquery name="parameter::set_default.set">
<querytext>
update apm_parameters set default_value = :value where package_key = :package_key and parameter_name = :parameter
</querytext>
</fullquery>
</queryset>
tcl/pools-init.tcl 0 → 100644
View file @ 57f3e57c
if {[ns_info version] eq "4.5"} {
set cfgsection "ns/server/[ns_info server]"
set minthreads [ns_config $cfgsection minthreads 5]
set maxthreads [ns_config $cfgsection maxthreads 10]
set maxconns [ns_config $cfgsection maxconnections 100]
set timeout [ns_config $cfgsection threadtimeout 120]
ns_pools set default -minthreads $minthreads -maxthreads $maxthreads -maxconns $maxconns -timeout $timeout
ns_log Notice "Default Pool: [ns_pools get default]"
# Setup optional threadpools
set poolSection $cfgsection/pools
set poolSet [ns_configsection $poolSection]
if {"$poolSet" ne ""} {
set poolSize [ns_set size $poolSet]
for {set i 0} {$i < $poolSize} {incr i} {
set poolName [ns_set key $poolSet $i]
set poolDescription [ns_set value $poolSet $i]
set poolConfigSection "ns/server/[ns_info server]/pool/$poolName"
set poolConfigSet [ns_configsection $poolConfigSection]
if {"$poolConfigSet" eq ""} {
continue
}
set poolMinthreads [ns_config $poolConfigSection minthreads $minthreads]
set poolMaxthreads [ns_config $poolConfigSection maxthreads $maxthreads]
set poolMaxconns [ns_config $poolConfigSection maxconnections $maxconns]
set poolTimeout [ns_config $poolConfigSection threadtimeout $timeout]
ns_pools set $poolName -minthreads $poolMinthreads -maxthreads $poolMaxthreads -maxconns $poolMaxconns -timeout $poolTimeout
ns_log Notice "$poolName Pool: [ns_pools get $poolName]"
set poolConfigSize [ns_set size $poolConfigSet]
for {set j 0} {$j < $poolConfigSize} {incr j} {
if {[string tolower [ns_set key $poolConfigSet $j]] eq "map"} &
#123;
set mapList [split [ns_set value $poolConfigSet $j]]
set poolMethod [lindex $mapList 0]
set poolPattern [lindex $mapList 1]
ns_pools register $poolName [ns_info server] $poolMethod $poolPattern
ns_log Notice "ns_pools registered $poolName [ns_info server] $poolMethod $poolPattern"
}
}
}
}
tcl/rollout-email-init.tcl deleted 100644 → 0
View file @ 8d660cc6
ad_library {
Initialize rollout email support. See also rollout-email-procs.tcl.
Parameter settings summary:
ns_section ns/server/${server}/acs/acs-rollout-support
#EmailDeliveryMode can be:
# default: Email messages are sent in the usual manner.
# log: Email messages are written to the server's error log.
# redirect: Email messages are redirected to the addresses specified
# by the EmailRedirectTo parameter. If this list is absent or
# empty, email messages are written to the server's error log.
# filter: Email messages are sent to in the usual manner if the
# recipient appears in the EmailAllow parameter, otherwise they are
# logged.
ns_param EmailDeliveryMode redirect
ns_param EmailRedirectTo somenerd@yourdomain.com,othernerd@yourdomain.com
#ns_param EmailAllow somenerd@yourdomain.com,othernerd@yourdomain.com
@author Andrew Grumet <aegrumet@alum.mit.edu>
@date 30 July 2002
}
switch [ns_config ns/server/[ns_info server]/acs/acs-rollout-support EmailDeliveryMode] {
log {
if { [ro::email::rename_ns_sendmail] } {
ns_log Notice "rollout-email-init.tcl: renaming ro::email::sendmail_log to ns_sendmail. Email messages will be written to the error log instead of getting sent."
rename ro::email::sendmail_log ns_sendmail
}
}
redirect {
if { [ro::email::rename_ns_sendmail] } {
ns_log Notice "rollout-email-init.tcl: renaming ro::email::sendmail_redirect to ns_sendmail. Email messages will be redirected to addresses specified by the EmailRedirectTo parameter of acs/acs-rollout-support ('[ns_config ns/server/[ns_info server]/acs/acs-rollout-support EmailRedirectTo]') or else logged if that parameter is not set ."
rename ro::email::sendmail_redirect ns_sendmail
}
}
filter {
if { [ro::email::rename_ns_sendmail] } {
ns_log Notice "rollout-email-init.tcl: renaming ro::email::sendmail_filter to ns_sendmail. Email messages will be logged unless this recipient's address is listed in the EmailAllow parameter of acs/acs-rollout-support ('[ns_config ns/server/[ns_info server]/acs/acs-rollout-support EmailAllow]') ."
rename ro::email::sendmail_filter ns_sendmail
}
}
}
tcl/rollout-email-procs.tcl deleted 100644 → 0
View file @ 8d660cc6
ad_library {
Rollout support email procs. These procs help manage differing
email behavior on dev/staging/production.
Parameter settings summary:
ns_section ns/server/${server}/acs/acs-rollout-support
#EmailDeliveryMode can be:
# default: Email messages are sent in the usual manner.
# log: Email messages are written to the server's error log.
# redirect: Email messages are redirected to the addresses specified
# by the EmailRedirectTo parameter. If this list is absent or
# empty, email messages are written to the server's error log.
# filter: Email messages are sent to in the usual manner if the
# recipient appears in the EmailAllow parameter, otherwise they are
# logged.
ns_param EmailDeliveryMode redirect
ns_param EmailRedirectTo somenerd@yourdomain.com,othernerd@yourdomain.com
#ns_param EmailAllow somenerd@yourdomain.com,othernerd@yourdomain.com
@author Andrew Grumet <aegrumet@alum.mit.edu>
@date 30 July 2002
}
namespace eval ro::email {
ad_proc -private get_template {} {
Returns a template for displaying email messages that would
have been sent in default delivery mode. It expects the following
variables to be set in the calling environment:
to, from, subject, body.
Usage pattern:
set message [ro::email::get_template]
some_proc [subst $message]
} {
return {
****************************************
To: $to
From: $from
Subject: $subject
$body
****************************************}
}
ad_proc -private sendmail_log {
to from subject body {extraheaders {}} {bcc {}}
} {
Writes email messages to the error log instead of sending them.
@author Andrew Grumet <aegrumet@alum.mit.edu>
@date 29 July 2002
} {
ns_log Notice "ro::email::sendmail_log: Logging email instead of sending:
[subst [ro::email::get_template]]"
return 1
}
ad_proc -private sendmail_redirect {
to from subject body {extraheaders {}} {bcc {}}
} {
Redirects email to the addresses listed in the EmailRedirectTo
parameter.
@author Andrew Grumet <aegrumet@alum.mit.edu>
@date 29 July 2002
} {
set targets [ns_config ns/server/[ns_info server]/acs/acs-rollout-support EmailRedirectTo]
if { ![string equal $targets ""] } {
set body "The following email would have been sent from \"[ad_parameter SystemName]\", but
was instead redirected to you.
[subst [ro::email::get_template]]
"
return [_old_ns_sendmail $targets $from $subject $body $extraheaders $bcc]
} else {
return [ro::email::sendmail_log $to $from $subject $body $extraheaders $bcc]
}
}
ad_proc -private sendmail_filter {
to from subject body {extraheaders {}} {bcc {}}
} {
Email messages are sent to in the usual manner if the
recipient appears in the EmailAllow parameter, otherwise they are
logged.
@author Andrew Grumet <aegrumet@alum.mit.edu>
@date 29 July 2002
} {
set allowed [ns_config ns/server/[ns_info server]/acs/acs-rollout-support EmailAllow]
# make sure we are comparing just the email address portion
# not a@b.com and a@b.com (Abc Def)
# note this takes out the name part as a side effect. -jfr
regexp {([a-zA-Z0-9][^ @]*)@([a-zA-Z0-9_.-]+\.[a-zA-Z]{2,6})} $to match beginning end
set to_for_comparison "${beginning}@${end}"
if { [lsearch [split $allowed ,] $to_for_comparison] >= 0 } {
return [_old_ns_sendmail $to_for_comparison $from $subject $body $extraheaders $bcc]
} else {
return [ro::email::sendmail_log $to_for_comparison $from $subject $body $extraheaders $bcc]
}
}
ad_proc -private rename_ns_sendmail {} {
Renames ns_sendmail to _old_ns_sendmail if _old_ns_sendmail
doesn't already exist. Returns 1 if successful, 0 otherwise.
@author Andrew Grumet <aegrumet@alum.mit.edu>
@date 6 June 2003
} {
ns_log Notice "rollout-email-procs.tcl: renaming ns_sendmail to _old_ns_sendmail."
if { [catch {
#We have to execute this code in the global namespace
#because otherwise _old_ns_sendmail will land in ro::email.
namespace eval :: { rename ns_sendmail _old_ns_sendmail }
} errMsg] } {
ns_log Notice "rollout-email-procs.tcl: rename failed! Error message: '$errMsg'"
return 0
}
return 1
}
}
tcl/tdom-procs.tcl 0 → 100644
View file @ 57f3e57c
# /packages/acs-tcl/tcl/tdom-procs.tcl
ad_library {
Procedures to make parsing XML using
TDOM a little easier
@author avni@ucla.edu (AK)
@creation-date 2004/10/19
@cvs-id $Id$
@tdom::get_node_object
@tdom::get_parent_node_object
@tdom::get_tag_value
@tdom::get_attribute_value
@tdom::get_node_xml
}
namespace eval tdom {}
ad_proc -public tdom::get_node_object {
parent_node_object
args
} {
Returns a tdom object to the args given
If the tdom object doesn't exist or the value is null, return null
<pre>
Example -----------------------------------------------------
XML: &lt;experiment&gt;
&lt;experimenter&gt;
&lt;first-name&gt;Annabelle Lee&lt;/first-name&gt;
&lt;last-name&gt;Poe&lt;/last-name&gt;
&lt;/experimenter&gt;
&lt;/experiment&gt;
Params: parent_node_object=$tdom_experiment_object
args=experimenter experimenter_two
Returns: TDOM object for experimenter node
End Example -------------------------------------------------
</pre>
} {
# Do a loop for the args. The first non null result is returned
set node_object ""
foreach node_name $args {
catch {set node_object [$parent_node_object getElementsByTagName "$node_name"]}
if {$node_object ne "" } {
return $node_object
}
}
return $node_object
}
ad_proc -public tdom::get_parent_node_object {
child_node_object
} {
Returns a tdom object for the parent node of the child node object passed in
} {
set parent_node_object ""
catch {set parent_node_object [$child_node_object parentNode]}
return $parent_node_object
}
ad_proc -public tdom::get_tag_value {
node_object
args
} {
Returns the tag value of the tag_name passed in
If tag doesn't exist or the value is null, returns null
<pre>
Example -----------------------------------------------------
XML: &lt;experiment-id&gt;1222&lt;/experiment-id&gt;
Params: node_object=$document
args=experiment-id EXPERIMENT-ID
Returns: 1222
End Example -------------------------------------------------
</pre>
} {
# Do a loop for the args. The first non null result is returned
set tag_value ""
foreach tag_name $args {
catch {set tag_value [[$node_object getElementsByTagName "$tag_name"] text]} errormsg
if {[string trim $tag_value] ne "" } {
return $tag_value
}
}
return $tag_value
}
ad_proc -public tdom::get_attribute_value {
node_object
attribute_name
{default_value ""}
} {
Returns the value of the attribute specified
} {
set attribute_value ""
catch {set attribute_value [$node_object getAttribute $attribute_name $default_value]}
return [string trim $attribute_value]
}
ad_proc -public tdom::get_node_xml {
node_object
} {
Returns xml of the data pointed to by the node object
If tag doesn't exist or the value is null, returns null
} {
set node_xml ""
catch {set node_xml [$node_object asXML]}
return [string trim $node_xml]
}
\ No newline at end of file
tcl/test/acs-tcl-apm-procs.tcl 0 → 100755
View file @ 57f3e57c
ad_library {
Tcl helper procedures for the acs-automated-testing tests of
the acs-tcl package.
@author Veronica De La Cruz (veronica@viaro.net)
@creation-date 11 August 2006
}
aa_register_case -cats {api smoke} -procs { apm_parameter_register } test_apm_parameter__register {
Test the apm_parameter_register procedure
@author Veronica De La Cruz (veronica@viaro.net)
} {
aa_run_with_teardown -rollback -test_code {
set package_list [db_list get_packages "select package_key from apm_package_types"]
aa_log "List of packages:\{$package_list\}"
set list_index [randomRange [expr {[llength $package_list] - 1}]]
set package_key [lrange $package_list $list_index $list_index]
set parameter_name [ad_generate_random_string]
set description [ad_generate_random_string]
set values { {number} {string} }
set index [randomRange 1]
# Choose randomly the parameter whether will be string or number.
# Also choose randomly its default value.
set datatype [lrange $values $index $index]
if {$datatype eq "number"} {
set default_value 0
} else {
set default_value [ad_generate_random_string]
}
aa_log "Paramater to be added: name : $parameter_name \n descr: $description \n datatype: $datatype \n default_value: $default_value"
set parameter_id [apm_parameter_register $parameter_name $description $package_key $default_value $datatype]
aa_true "Parameter register succeeded" [exists_and_not_null parameter_id]
}
}
aa_register_case -cats {api smoke} -procs {apm_package_instance_new} test_apm_package_instance__new {
Test the apm_package_instance_new procedure
@author Veronica De La Cruz (veronica@viaro.net)
} {
aa_run_with_teardown -rollback -test_code {
set package_list [db_list get_packages "select package_key from apm_package_types"]
aa_log "List of packages:\{$package_list\}"
set list_index [randomRange [expr {[llength $package_list] - 1}]]
set package_key [lrange $package_list $list_index $list_index]
set instance_name $package_key
append instance_name "-[ad_generate_random_string]"
aa_log "Package to be instantiated: $package_key"
aa_log "Instance name to be added: $instance_name"
set error_ocurred [catch {set package_id [apm_package_instance_new -package_key $package_key -instance_name $instance_name ]} err_men]
aa_log "Error Message $error_ocurred: $err_men "
aa_true "Setting the new instance succeeded" [exists_and_not_null package_id]
}
}
tcl/test/ad-proc-test-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
Tests for ad_proc.
@author Lee Denison lee@xarg.co.uk
@creation-date 2005-03-11
}
aa_register_case -cats {api smoke} ad_proc_create_callback {
Tests the creation of a callback and an implementation with
some forced error cases.
} {
aa_true "throw error for ad_proc -callback with extraneous proc body" \
[catch {
ad_proc -callback a_callback { arg1 arg2 } { docs } { body }
} error]
aa_true "throw error for callback called contract" \
[catch {
ad_proc -callback contract { arg1 arg2 } { docs } -
} error]
ad_proc -callback a_callback { -arg1 arg2 } { this is a test callback } -
set callback_procs [info procs ::callback::a_callback::*]
aa_true "creation of a valid callback contract with '-' body" \
[expr {[lsearch -exact \
$callback_procs \
::callback::a_callback::contract] >= 0}]
ad_proc -callback a_callback_2 { arg1 arg2 } { this is a test callback } {}
set callback_procs [info procs ::callback::a_callback_2::*]
aa_true "creation of a valid callback contract with no body" \
[expr {[lsearch -exact \
$callback_procs \
::callback::a_callback_2::contract] >= 0}]
aa_true "throw error for missing -callback on implementation definition" \
[catch {
ad_proc -impl an_impl {} { docs } { body }
} error]
aa_true "throw error for implementation named impl" \
[catch {
ad_proc -callback a_callback -impl impl {} { docs } { body }
} error]
ad_proc -callback a_callback -impl an_impl {} {
this is a test callback implementation
} {
}
set impl_procs [info procs ::callback::a_callback::impl::*]
aa_true "creation of a valid callback implementation" \
[expr {[lsearch -exact \
$impl_procs \
::callback::a_callback::impl::an_impl] >= 0}]
}
ad_proc -callback a_callback {
-arg1:required arg2
} {
this is a test callback
} -
ad_proc -callback b_callback {
-arg1:required arg2
} {
this is a test callback
} -
ad_proc -callback c_callback {
-arg1:required arg2
} {
this is a test callback
} -
ad_proc -callback a_callback -impl an_impl1 {} {
this is a test callback implementation
} {
return 1
}
ad_proc -callback a_callback -impl an_impl2 {} {
this is a test callback implementation which does
an upvar of an array.
} {
upvar $arg1 arr
if {[info exists arr(test)]} {
return $arr(test)
}
return {}
}
ad_proc -callback a_callback -impl fail_impl {} {
this is a test callback implementation
} {
error "should fail"
}
ad_proc EvilCallback {} {
This is a test callback implementation that should not be invoked.
} {
error "Should not be invoked"
}
aa_register_case -cats {api smoke} ad_proc_fire_callback {
Tests a callback with two implementations .
} {
aa_true "throws error for invalid arguments even if no implementations" \
[catch {callback c_callback bar} error]
aa_true "callback returns empty list with no implementations" \
[expr {[llength [callback b_callback -arg1 foo bar]] == 0}]
set foo(test) 2
aa_true "callback returns value for each defined callback and catches the error callback" \
[expr {[llength [callback -catch a_callback -arg1 foo bar]] == 2}]
aa_true "callback returns correct value for specified implementation" \
[expr {[callback -impl an_impl1 a_callback -arg1 foo bar] == 1}]
aa_true "callback returns correct value for an array ref" \
[expr {[callback -impl an_impl2 a_callback -arg1 foo bar] == 2}]
aa_true "callback works with {} args" \
[expr {[callback -impl an_impl2 a_callback -arg1 {} {}] == {}}]
aa_true "callback errors with missing arg" \
[expr {[catch {callback -impl an_impl2 a_callback -arg1 foo} err] == 1}]
aa_true "throws error for invalid arguments with implementations" \
[catch {callback a_callback bar} error]
aa_true "throws error when a non-existent implementation is specified" \
[catch {callback -impl non_existent a_callback -arg1 foo bar} error]
aa_true "throws error without -catch when an error occurs in a callback" \
[catch {callback a_callback -arg1 foo bar} error]
set x [catch {callback -impl an_impl2 a_callback -arg1 foo {[EvilCallback]}} error]
aa_false "EvilCallback not invoked returned $error" $x
set x [catch {callback -impl an_impl2 a_callback -arg1 {[EvilCallback]} bar} error]
aa_false "EvilCallback not invoked returned $error" $x
}
tcl/test/apm-parameter-test-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
Testing for parameter registration
@author Adrian Catalan (ykro@galileo.edu)
@creation-date 2006-08-10
}
aa_register_case -cats {api smoke} parameter_register_test {
Test the registration of a parameter
} {
set parameter_id [db_nextval "acs_object_id_seq"]
set parameter_name [ad_generate_random_string]
set description "Description for the new parameter"
set package_key "acs-tcl"
set default_value "5"
set datatype "number"
set scope "instance"
aa_log "Registering an instance parameter"
apm_parameter_register -parameter_id $parameter_id -scope $scope $parameter_name $description $package_key $default_value $datatype
set package_id [apm_package_id_from_key $package_key]
aa_true "check apm_parameter_register instance parameter" [string equal [parameter::get -package_id $package_id -parameter $parameter_name] $default_value]
aa_log "Unregistering an instance parameter"
apm_parameter_unregister $parameter_id
set scope "global"
aa_log "Registering a global parameter"
apm_parameter_register -parameter_id $parameter_id -scope $scope $parameter_name $description $package_key $default_value $datatype
aa_true "check apm_parameter_register global parameter" [string equal [parameter::get_global_value -package_key $package_key -parameter $parameter_name] $default_value]
aa_log "Unregistering an global parameter"
apm_parameter_unregister $parameter_id
}
tcl/test/application-data-link-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
Tests for applicaiton data links
}
aa_register_case -cats api data_links_scan_links {
Test scanning content for object URLs
} {
# get a new object_id from the sequence, this object will not exist
set nonexistant_object_id [db_nextval "acs_object_id_seq"]
set text {Some random text <img src="/o/0"> <a href="/file/0"> <img src="/image/0"> <img src="/image/${nonexistant_object_id}/"> <img src="/image/0/thumbnail"> <img src="/image/0/info"> <a href="http://example.com/o/9">
Some More Random Text <a href="/o/junk"> <a href="/file/junk"> <a href="/image/junk"> /o/10 /file/11 /image/12
/o/[junk] /file/[junk] /image/[junk]
/o/" /file/" /image/"
/o/[ /file/[ /image/[
}
append text "<a href=\"[ad_url]/o/0\"> "
aa_log "ad_url = '[ad_url]'"
set links [application_data_link::scan_for_links -text $text]
set correct_links [list 0]
aa_log "Links = '${links}'"
aa_true "Number of links found is correct" \
[expr {[llength $correct_links] eq [llength $links]}]
}
aa_register_case -cats api data_links_update_links {
Test updating references,
tests scan_for_links
and delete_links in the process
} {
aa_run_with_teardown \
-rollback \
-test_code \
{
# create some test objects
set name [ns_mktemp "cr_item__XXXXXX"]
for {set i 0} {$i<10} {incr i} {
set o($i) [content::item::new \
-name ${name}_$i \
-title ${name}_$i]
}
# generate some text with links between the objects
foreach n [array names o] {
append text "\nTest Content Link to $o($n) <a href=\"/o/$o($n)\">Link</a> \n"
}
# update the links
foreach n [array names o] {
application_data_link::update_links_from \
-object_id $o($n) \
-text $text
}
# scan for links and compare
set correct_links [lsort \
[application_data_link::scan_for_links \
-text $text]]
aa_true "Correct links is not empty" [llength $correct_links]
foreach n [array names o] {
set links [lsort \
[application_data_link::get_links_from \
-object_id $o($n)]]
aa_true "Object \#${n} references correct" \
[expr {$correct_links eq $links}]
}
# now change the text and update one of the objects
for {set i 0} {$i < 5} {incr i} {
append new_text "\nTest Content Link to $o($i) /o/$o($i) \n"
}
for {set i 0} {$i < 5} {incr i} {
application_data_link::update_links_from \
-object_id $o($i) \
-text $new_text
}
set new_correct_links [lsort \
[application_data_link::scan_for_links \
-text $new_text]]
for {set i 0} {$i < 5} {incr i} {
set links [lsort \
[application_data_link::get_links_from \
-object_id $o($i)]]
aa_true "Object \#${i} updated references correct" \
[expr {$new_correct_links eq $links}]
}
}
}
aa_register_case -cats api data_links_scan_links_with_tag {
Test scanning content for object URLs with relation tag
} {
# get a new object_id from the sequence, this object will not exist
set nonexistant_object_id [db_nextval "acs_object_id_seq"]
set text {Some random text <img src="/o/0"> <a href="/file/0"> <img src="/image/0"> <img src="/image/${nonexistant_object_id}/"> <img src="/image/0/thumbnail"> <img src="/image/0/info"> <a href="http://example.com/o/9">
Some More Random Text <a href="/o/junk"> <a href="/file/junk"> <a href="/image/junk"> /o/10 /file/11 /image/12
/o/[junk] /file/[junk] /image/[junk]
/o/" /file/" /image/"
/o/[ /file/[ /image/[
}
append text "<a href=\"[ad_url]/o/0\"> "
aa_log "ad_url = '[ad_url]'"
set links [application_data_link::scan_for_links -text $text]
set correct_links [list 0]
aa_log "Links = '${links}'"
aa_true "Number of links found is correct" \
[expr {[llength $correct_links] eq [llength $links]}]
}
aa_register_case -cats api data_links_update_links_with_tag {
Test updating references,
tests scan_for_links
and delete_links in the process.
Uses relation tags
} {
aa_run_with_teardown \
-rollback \
-test_code \
{
# create some test objects
set name [ns_mktemp "cr_item__XXXXXX"]
for {set i 0} {$i<10} {incr i} {
set o($i) [content::item::new \
-name ${name}_$i \
-title ${name}_$i]
}
# generate some text with links between the objects
foreach n [array names o] {
append text "\nTest Content Link to $o($n) <a href=\"/o/$o($n)\">Link</a> \n"
}
# update the links
foreach n [array names o] {
application_data_link::update_links_from \
-object_id $o($n) \
-text $text \
-relation_tag tag
}
# scan for links and compare
set correct_links [lsort \
[application_data_link::scan_for_links \
-text $text]]
aa_true "Correct links is not empty" [llength $correct_links]
foreach n [array names o] {
set links [lsort \
[application_data_link::get_links_from \
-object_id $o($n) -relation_tag tag]]
aa_true "Object \#${n} references correct" \
[expr {$correct_links eq $links}]
}
# now change the text and update one of the objects
for {set i 0} {$i < 5} {incr i} {
append new_text "\nTest Content Link to $o($i) /o/$o($i) \n"
}
for {set i 0} {$i < 5} {incr i} {
application_data_link::update_links_from \
-object_id $o($i) \
-text $new_text \
-relation_tag tag
}
set new_correct_links [lsort \
[application_data_link::scan_for_links \
-text $new_text]]
for {set i 0} {$i < 5} {incr i} {
set links [lsort \
[application_data_link::get_links_from \
-object_id $o($i) \
-relation_tag tag]]
aa_true "Object \#${i} updated references correct" \
[expr {$new_correct_links eq $links}]
}
}
}
aa_register_case -cats api data_links_with_tag {
Test creating new link, exists test, get, get_linked and delete. Uses relation tags.
} {
aa_run_with_teardown \
-rollback \
-test_code \
{
# create some test objects
set name [ns_mktemp "cr_item__XXXXXX"]
for {set i 0} {$i<6} {incr i} {
set o($i) [content::item::new \
-name ${name}_$i \
-title ${name}_$i]
}
aa_log "Creating link between objects"
application_data_link::new -this_object_id $o(0) -target_object_id $o(1) -relation_tag tag
aa_true "Verify objects are linked" \
[application_data_link::link_exists \
-from_object_id $o(0) \
-to_object_id $o(1) \
-relation_tag tag]
aa_log "Deleting links attached to first object"
application_data_link::delete_links -object_id $o(0)
aa_false "Verify objects are deleted" \
[application_data_link::link_exists \
-from_object_id $o(0) \
-to_object_id $o(1) \
-relation_tag tag]
aa_log "Creating many links between objects"
application_data_link::new -this_object_id $o(0) -target_object_id $o(1) -relation_tag tag1
application_data_link::new -this_object_id $o(0) -target_object_id $o(2) -relation_tag tag1
application_data_link::new -this_object_id $o(0) -target_object_id $o(3) -relation_tag tag2
application_data_link::new -this_object_id $o(3) -target_object_id $o(4) -relation_tag tag2
application_data_link::new -this_object_id $o(3) -target_object_id $o(5) -relation_tag tag2
aa_true "Verify link for tag1" [expr [llength [application_data_link::get_linked -from_object_id $o(0) \
-to_object_type [acs_object_type $o(0)] -relation_tag tag1]] == 2]
aa_true "Verify link for tag2" [expr [llength [application_data_link::get_linked -from_object_id $o(3) \
-to_object_type [acs_object_type $o(3)] -relation_tag tag2]] == 3]
aa_true "Verify content link" [expr [llength [application_data_link::get_linked_content -from_object_id $o(0) \
-to_content_type content_revision -relation_tag tag1]] == 2]
aa_true "Verify links to one object with multiple link tags" \
[expr [llength [application_data_link::get -object_id $o(0) -relation_tag tag1]] == 2]
aa_true "Verify links to one object with multiple link tags" \
[expr [llength [application_data_link::get -object_id $o(0) -relation_tag tag2]] == 1]
}
}
\ No newline at end of file
tcl/test/community-core-test-procs.tcl 0 → 100644
View file @ 57f3e57c
#
ad_library {
@author byron Haroldo Linares Roman (bhlr@galileo.edu)
@creation-date 2006-07-28
@arch-tag: 0D0EAC28-2481-4BEE-9645-A143B939DBCA
@cvs-id $Id$
}
aa_register_case \
-cats {api smoke} \
-procs {cc_lookup_email_user cc_email_from_party} \
community_cc_procs \
{
test community core procs returned values
} {
set user_id [db_nextval acs_object_id_seq]
set username [ad_generate_random_string]
set password [ad_generate_random_string]
aa_run_with_teardown -test_code {
array set user_info [twt::user::create -user_id $user_id]
set user_id_p [cc_lookup_email_user $user_info(email)]
aa_true "User ID CORRECTO" \
[string match $user_id_p $user_info(user_id)]
set email_p [cc_email_from_party $user_info(user_id)]
aa_log "returns: $email_p , creation: $user_info(email)"
aa_true "Email correcto" \
[string match $email_p [string tolower $user_info(email)]]
}
}
aa_register_case \
-cats {api smoke} \
-procs {person::person_p person::get person::new person::update person::get_bio person::update_bio} \
person_procs_test \
{
test if the values returned by the person procs are correct
} {
set user_id [db_nextval acs_object_id_seq]
set username "[ad_generate_random_string]"
set email "${username}@test.test"
set password [ad_generate_random_string]
set first_names [ad_generate_random_string]
set last_name [ad_generate_random_string]
array set user_info [auth::create_user -user_id $user_id -username $username \
-email $email -first_names $first_names -last_name $last_name \
-password $password -secret_question [ad_generate_random_string] \
-secret_answer [ad_generate_random_string]]
if { $user_info(creation_status) ne "ok" } {
# Could not create user
error "Could not create test user with username=$username user_info=[array get user_info]"
}
set user_info(password) $password
set user_info(email) $email
aa_log "Created user with email=\"$email\" and password=\"$password\""
aa_run_with_teardown -rollback \
-test_code {
aa_true "party is a person" [person::person_p -party_id $user_id]
array set user_inf [person::get -person_id $user_info(user_id)]
aa_true "first_names correct" [string match $user_inf(first_names) $first_names]
aa_true "last_name correct" [string match $user_inf(last_name) $last_name]
aa_true "person_id correct" [string match $user_inf(person_id) $user_id]
aa_true "correct name" [string match [person::name -person_id $user_info(user_id)] "$first_names $last_name"]
set prs_id [person::new -first_names $first_names -last_name $last_name -email "${email}s"]
set email_p [cc_email_from_party $prs_id]
aa_true "New person pass" [string match $email_p [string tolower "${email}s"]]
person::update -person_id $prs_id -first_names "hh$first_names" -last_name "hh$last_name"
aa_true "name changed" [string match [person::name -person_id $prs_id] "hh$first_names hh$last_name"]
set bio "bio :: [ad_generate_random_string] :: bio"
person::update_bio -person_id $prs_id -bio $bio
aa_true "bio(graphy) ok" [string match $bio [person::get_bio -person_id $prs_id -exists_var bio_p]]
person::delete -person_id $prs_id
aa_true "person deleted" ![person::person_p -party_id $prs_id]
}
}
aa_register_case \
-cats {api smoke} \
-procs {party::get_by_email party::update} \
party_procs_test \
{
test if the values returned by the party procs are correct
} {
set user_id [db_nextval acs_object_id_seq]
set username "[ad_generate_random_string]"
set email "${username}@test.test"
set password [ad_generate_random_string]
set first_names [ad_generate_random_string]
set last_name [ad_generate_random_string]
set url "url[ad_generate_random_string]"
array set user_info [auth::create_user -user_id $user_id -username $username -email $email -first_names $first_names \
-last_name $last_name -password $password \
-secret_question [ad_generate_random_string] \
-secret_answer [ad_generate_random_string]]
if { $user_info(creation_status) ne "ok" } {
# Could not create user
error "Could not create test user with username=$username user_info=[array get user_info]"
}
set user_info(password) $password
set user_info(email) $email
aa_log "Created user with email=\"$email\" and password=\"$password\""
aa_run_with_teardown -rollback \
-test_code {
aa_true "correct party_id" [string match [party::get_by_email -email $email] $user_info(user_id)]
party::update -party_id $user_info(user_id) -email "${email}2" -url $url
aa_true "correct party with new mail" [string match [party::get_by_email -email "${email}2"] $user_info(user_id)]
}
}
tcl/test/datamodel-test-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
Sweep the all the files in the system looking for systematic errors.
@author Jeff Davis
@creation-date 2005-02-28
@cvs-id $Id$
}
aa_register_case -cats {db smoke production_safe} datamodel__named_constraints {
Check that all the contraints meet the constraint naming standards.
@author Jeff Davis davis@xarg.net
} {
set db_is_pg_p [string equal [db_name] "PostgreSQL"]
if { $db_is_pg_p } {
set get_constraints "select
cla.relname as table_name,
con.conrelid,
con.conname as constraint_name,
CASE
when con.contype='c' then 'ck'
when con.contype='f' then 'fk'
when con.contype='p' then 'pk'
when con.contype='u' then 'un'
else ''
END as constraint_type,
con.conkey,
'' as search_condition
from
pg_constraint con,
pg_class cla
where con.conrelid != 0 and cla.oid=con.conrelid
order by table_name,constraint_name"
set get_constraint_col "select attname from pg_attribute where attnum = :columns_list and attrelid = :conrelid"
} else {
# Oracle
set get_constraints "select
acc.*, ac.search_condition,
decode(ac.constraint_type,'C','CK','R','FK','P','PK','U','UN','') as constraint_type
from
(select count(column_name) as columns, table_name, constraint_name from user_cons_columns group by table_name, constraint_name) acc,
user_constraints ac
where ac.constraint_name = acc.constraint_name
order by acc.table_name, acc.constraint_name"
set get_constraint_col "select column_name from user_cons_columns where constraint_name = :constraint_name"
}
db_foreach check_constraints $get_constraints {
if { $db_is_pg_p || [string last "$" $table_name] eq -1 } {
regsub {_[[:alpha:]]+$} $constraint_name "" name_without_type
set standard_name "${name_without_type}_${constraint_type}"
if { $db_is_pg_p } {
set columns_list [split [string range $conkey 1 end-1] ","]
set columns [llength $columns_list]
}
if { $columns eq 1 } {
set column_name [db_string get_col $get_constraint_col]
# NOT NULL constraints (oracle only)
if { [string equal $search_condition "\"$column_name\" IS NOT NULL"] } {
set constraint_type "NN"
}
set standard_name ${table_name}_${column_name}_${constraint_type}
if { [string length $standard_name] > 30 } {
# Only check the abbreviation
set standard_name "${name_without_type}_${constraint_type}"
}
}
# Giving a hint for constraint naming
if {[string range $standard_name 0 2] eq "SYS"} {
set hint "unnamed"
} else {
set hint "hint: $standard_name"
}
if { $standard_name ne $constraint_name } {
aa_log_result fail "Table $table_name constraint $constraint_name ($constraint_type) violates naming standard ($hint)"
}
}
}
}
aa_register_case -cats {db smoke production_safe} datamodel__acs_object_type_check {
Check that the object type tables exist and that the id column is present and the
name method works.
@author Jeff Davis davis@xarg.net
} {
db_foreach object_type {select * from acs_object_types} {
if {[string tolower $table_name] ne $table_name } {
aa_log_result fail "Type $object_type: table_name $table_name mixed case"
}
if {[string tolower $id_column] ne $id_column } {
aa_log_result fail "Type $object_type: id_column $id_column mixed case"
}
set table_name [string tolower $table_name]
set id_column [string tolower $id_column]
set the_pk {}
while { [string is space $table_name] && $object_type ne $supertype } {
if {![db_0or1row get_supertype "select * from acs_object_types where object_type = :supertype"]} {
break
}
}
if {![db_table_exists $table_name]} {
aa_log_result fail "Type $object_type: table $table_name does not exit"
} else {
if {[string is space $id_column]} {
aa_log_result fail "Type $object_type: id_column not specified"
} else {
# we could just check the column exists but since we want to
# check the name method try at least to get a real object_id
if {[catch {db_0or1row check_exists "select min($id_column) as the_pk from $table_name"} errMsg]} {
aa_log_result fail "Type $object_type: select $id_column from $table_name failed:\n$errMsg"
}
}
}
if {![string is space $name_method]} {
if {[string tolower $name_method] ne $name_method } {
aa_log_result fail "Type $object_type: name method $name_method mixed case"
}
set name_method [string tolower $name_method]
if {[string is integer -strict $the_pk]} {
# intentionally don't use bind variables here which is ok
# since we just checked the_pk was an integer
if { [catch {db_0or1row name_method "select ${name_method}($the_pk) as NAME from dual"} errMsg] } {
aa_log_result fail "Type $object_type: name method $name_method failed\n$errMsg"
}
}
}
if {![string is space $type_extension_table]
&& ![db_table_exists $type_extension_table]} {
aa_log_result fail "Type $object_type: type extension table $type_extension_table does not exist"
}
}
}
aa_register_case -cats {db smoke production_safe} datamodel__acs_attribute_check {
Check that the acs_attribute column is present and the datatype is vaguely
consistent with the db datatype.
@author Jeff Davis davis@xarg.net
} {
array set allow_types {
string {TEXT VARCHAR CHAR VARCHAR2}
boolean {BOOL INT2 INT4 CHAR}
number {NUMERIC INT2 INT4 INT8 FLOAT4 FLOAT8 NUMBER}
integer {INT2 INT4 INT8 NUMBER}
money {NUMERIC FLOAT4 FLOAT8}
timestamp {TIMESTAMPTZ}
time_of_day {TIMESTAMPTZ}
enumeration {INT2 INT4 INT8}
url {VARCHAR TEXT VARCHAR2}
email {VARCHAR TEXT VARCHAR2}
text {VARCHAR TEXT CLOB VARCHAR2}
keyword {CHAR VARCHAR TEXT VARCHAR2}
}
db_foreach attribute {select a.*, lower(ot.table_name) as obj_type_table from acs_attributes a, acs_object_types ot where ot.object_type = a.object_type order by a.object_type} {
if {[string tolower $table_name] ne $table_name } {
aa_log_result fail "Type $object_type attribute $table_name.$attribute_name mixed case"
set table_name [string tolower $table_name]
} elseif {[string is space $table_name]} {
set table_name $obj_type_table
}
switch -exact $storage {
type_specific {
if {![info exists columns($table_name)]} {
set columns($table_name) [db_columns $table_name]
}
if {[string is space $column_name]} {
set column_name $attribute_name
}
if {[lsearch $columns($obj_type_table) $column_name] < 0} {
aa_log_result fail "Type $object_type attribute column $column_name not found in $obj_type_table"
} else {
# check the type of the column is vaguely like the acs_datatype type.
if {[info exists allow_types($datatype)]} {
set actual_type [db_column_type $table_name $column_name]
if {$actual_type eq "-1"} {
aa_log_result fail "Type $object_type attribute $attribute_name database type get for ($table_name.$column_name) failed"
} else {
if {[lsearch $allow_types($datatype) $actual_type] < 0} {
aa_log_result fail "Type $object_type attribute $attribute_name database type was $actual_type for $datatype"
}
}
}
}
}
generic {
# nothing really to do here...
}
default {
# it was null which is probably not sensible.
aa_log_result fail "Type $object_type attribute $table_name.$attribute_name storage type null"
}
}
}
}
tcl/test/doc-check-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
Check all the proc documentation
@author Jeff Davis
@creation-date 2005-02-28
@cvs-id $Id$
}
aa_register_case -cats {smoke production_safe} documentation__check_proc_doc {
checks if documentation exists for public procs.
@author Jeff Davis davis@xarg.net
} {
set count 0
set good 0
foreach p [lsort -dictionary [nsv_array names api_proc_doc]] {
array set pa [nsv_get api_proc_doc $p]
if { $pa(public_p)
&& !($pa(deprecated_p) || $pa(warn_p))
} {
incr count
if { [string is space $pa(main)] } {
aa_log_result fail "No documentation for public proc $p"
} else {
incr good
}
}
array unset pa
}
aa_log "Found $good good of $count checked"
}
aa_register_case -cats {smoke production_safe} -error_level warning documentation__check_deprecated_see {
checks if deprecated procs have an @see clause
@author Jeff Davis davis@xarg.net
} {
set count 0
set good 0
foreach p [lsort -dictionary [nsv_array names api_proc_doc]] {
array set pa [nsv_get api_proc_doc $p]
if { $pa(deprecated_p)||$pa(warn_p) } {
incr count
if { ![info exists pa(see)] || [string is space $pa(see)] } {
aa_log_result fail "No @see for deprecated proc $p"
} else {
incr good
}
}
array unset pa
}
aa_log "Found $good of $count procs checked"
}
tcl/test/file-test-procs.tcl 0 → 100644
View file @ 57f3e57c
This diff is collapsed.
tcl/test/html-email-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
Test html email procs
}
aa_register_case -cats {api smoke} build_mime_message {
Basic test of build mime mesage
} {
aa_false "Build mime message, no error" \
[catch {build_mime_message \
"Test Mesage" \
"<p>Test Message</p>"} errmsg]
aa_log err=$errmsg
aa_false "Package require mime package found" \
[catch {package require mime} errmsg]
}
\ No newline at end of file
tcl/test/memoizing-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
automated-testing for memoizing procs
@author Adrian Catalan (ykro@galileo.edu)
@creation-date 2006-07-28
}
namespace eval memoizing_procs_test {}
ad_proc -private memoizing_procs_test::return_string {
{-name:required}
} {
Test proc that returns a string
} {
set response "This is a test for "
append response $name
return $response
}
ad_proc -private memoizing_procs_test::return_upper_case_text {
{-txt:required}
} {
Test proc that returns a string in upper case
} {
set response $txt
append response " in upper case is "
append response [string toupper $txt]
return $response
}
aa_register_case -cats {api smoke} ad_proc_cache {
Test cache of a proc executed before
} {
aa_log "caching a proc"
util_memoize {memoizing_procs_test::return_string -name "foobar"}
aa_log "checking if the proc is cached"
set success_p [util_memoize_cached_p {memoizing_procs_test::return_string -name "foobar"}]
aa_equals "proc was cached succesful" $success_p 1
}
aa_register_case -cats {api smoke} ad_proc_flush {
Test flush of a proc cached
} {
aa_log "caching"
util_memoize {memoizing_procs_test::return_string -name "foobar"}
aa_log "checking if the proc is cached"
aa_log "flushing"
util_memoize_flush_regexp {return_upper_case_text}
set success_p [util_memoize_cached_p {memoizing_procs_test::return_upper_case_text -txt "foobar"}]
aa_equals "proc was flushed succesful" $success_p 0
}
tcl/test/multirow-test.adp 0 → 100644
View file @ 57f3e57c
<multiple name="test_rows"><a href="@test_rows.url@">@test_rows.label@</a></multiple>
tcl/test/multirow-test.tcl 0 → 100644
View file @ 57f3e57c
ad_page_contract {
Tests the ad_context_bar_multirow referenced in navigation-procs.tcl.
@author Juan Pablo Amaya jpamaya@unicauca.edu.co
@creation-date 21 September 2006
}
ad_context_bar_multirow -multirow test_rows -from_node $from_node -node_id $node_id $context
tcl/test/navigation-procs.tcl 0 → 100755
View file @ 57f3e57c
This diff is collapsed.
tcl/test/object-test-case-procs.tcl 0 → 100644
View file @ 57f3e57c
This diff is collapsed.
tcl/test/openacs-kernel-procs.tcl 0 → 100644
View file @ 57f3e57c
ad_library {
Tests for additional utilities.
@creation-date 03 August 2006
}
aa_register_case -cats {api smoke} -procs {oacs_util::csv_foreach} csv_foreach {
Test block execution for rows in a csv file.
} {
aa_run_with_teardown -test_code {
# Create cvs file
set file_loc "/tmp/test.csv"
set file_id [open $file_loc w]
puts $file_id "first_name,last_name,instrument"
puts $file_id "Charles,Mingus,Bass"
puts $file_id "Miles,Davis,Trumpet"
puts $file_id "Jhon,Coltrane,Saxo"
puts $file_id "Charlie,Parker,Saxo"
puts $file_id "Thelonius,Monk,Piano"
close $file_id
set csv_data "\nfirst_name,last_name,instrument\nCharles,Mingus,Bass\nMiles,Davis,Trumpet\nJhon,Coltrane,Saxo\nCharlie,Parker,Saxo\nThelonius,Monk,Piano"
aa_log "CSV file created with artists data:\n $csv_data"
set artist_list {}
oacs_util::csv_foreach -file $file_loc -array_name row\
{
lappend artist_list "$row(first_name) $row(last_name) - $row(instrument)"
}
aa_equals "Getting artists from csv file" $artist_list {{Charles Mingus - Bass}\
{Miles Davis - Trumpet}\
{Jhon Coltrane - Saxo}\
{Charlie Parker - Saxo}\
{Thelonius Monk - Piano}}
} -teardown_code {
file delete -force $file_loc
}
}
aa_register_case -cats {api smoke} -procs {oacs_util::process_objects_csv} process_objects_csv {
Test object creation for every row in a csv file.
} {
aa_run_with_teardown -rollback -test_code {
# Create cvs file of persons
set file_loc "/tmp/test.csv"
set file_id [open $file_loc w]
puts $file_id "email,first_names,last_name"
puts $file_id "cmingus@foo.bar,Charles,Mingus"
puts $file_id "mdavis@foo.bar,Miles,Davis"
puts $file_id "cparker@foo.bar,Charlie,Parker"
close $file_id
set csv_data "\nemail,first_names,last_name\ncmingus@foo.bar,Charles,Mingus\nmdavis@foo.bar,Miles,Davis\ncparker@foo.bar,Charlie,Parker"
aa_log "CSV file for \"person\" objects creation with data:\n $csv_data"
set person_ids [oacs_util::process_objects_csv -object_type "person" -file $file_loc]
aa_log "Persons id's created: $person_ids"
set person_list {}
foreach person_id $person_ids {
array set person_array [person::get -person_id $person_id]
lappend person_list "$person_array(first_names) $person_array(last_name)"
}
aa_equals "Getting persons from database table \"persons\"" $person_list {{Charles Mingus}\
{Miles Davis}\
{Charlie Parker}}
} -teardown_code {
file delete -force $file_loc
}
}
tcl/test/test-membership-rel-procs.tcl 0 → 100644
View file @ 57f3e57c
This diff is collapsed.
tcl/test/test-permissions-procs.tcl 0 → 100644
View file @ 57f3e57c
This diff is collapsed.
tcl/test/test-set-cookie-procs.tcl 0 → 100644
View file @ 57f3e57c
This diff is collapsed.
tcl/test/whos-online-procs.tcl 0 → 100644
View file @ 57f3e57c
This diff is collapsed.
tcl/util-diff-procs.tcl 0 → 100644
View file @ 57f3e57c
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment