Index: openacs-4/packages/xotcl-core/xotcl-core.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/xotcl-core.info,v
diff -u -r1.23 -r1.24
--- openacs-4/packages/xotcl-core/xotcl-core.info 19 Feb 2007 10:03:35 -0000 1.23
+++ openacs-4/packages/xotcl-core/xotcl-core.info 9 Mar 2007 11:02:55 -0000 1.24
@@ -8,10 +8,10 @@
t
xotcl
-
+
Gustaf Neumann
XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes)
- 2007-02-19
+ 2007-03-09
This component contains some core functionality for OACS
applications using XOTcl. It includes
XOTcl thread handling for OACS (supporting persistent and
@@ -30,11 +30,13 @@
0.41: supporting storage_type file, on_submit method and html for forms;
0.43: context and connection context;
0.44: use connection_context, sch regression test works;
-0.45: xo:db require operations;
+0.45: xo:db require operations;
+0.48: policies
+
BSD-Style
0
-
+
Index: openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl,v
diff -u -r1.10 -r1.11
--- openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 15 Sep 2006 16:33:06 -0000 1.10
+++ openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 9 Mar 2007 11:02:56 -0000 1.11
@@ -177,7 +177,7 @@
}
Table instproc render_with {renderer trn_mixin} {
- #my log "--"
+ #my log "-- renderer=$renderer"
set cl [self class]
[self] mixin ${cl}::$renderer
foreach child [$cl info classchildren] {
@@ -321,6 +321,9 @@
-instproc init_renderer {} {
#my log "--"
my set __rowcount 0
+ my set css.table-class list
+ my set css.tr.even-class list-even
+ my set css.tr.odd-class list-odd
}
TABLE instproc render-actions {} {
@@ -350,7 +353,10 @@
html::tr {html::td { html::t [my set no_data]}}
} else {
foreach line [my children] {
- html::tr -class [expr {[my incr __rowcount]%2 ? "list-odd" : "list-even" }] {
+ #my log "--LINE vars=[my info vars] cL: [[self class] info vars] r=[my renderer]"
+ html::tr -class [expr {[my incr __rowcount]%2 ?
+ [my set css.tr.odd-class] :
+ [my set css.tr.even-class] }] {
foreach field [[self]::__columns children] {
html::td [concat [list class list] [$field html]] {
$field render-data $line
@@ -363,7 +369,7 @@
TABLE instproc render {} {
if {![my isobject [self]::__actions]} {my actions {}}
- html::table -class list {
+ html::table -class [my set css.table-class] {
my render-actions
my render-body
}
@@ -475,7 +481,7 @@
html::div {
my render-actions
html::div -class table {
- html::table -class list {my render-body}
+ html::table -class [my set css.table-class] {my render-body}
}
}
}
@@ -484,7 +490,20 @@
Class create TABLE2::Field -superclass TABLE::Field
Class create TABLE2::AnchorField -superclass TABLE::AnchorField
Class create TABLE2::ImageField -superclass TABLE::ImageField
-
+
+ Class TABLE3 \
+ -superclass TABLE2 \
+ -instproc init_renderer {} {
+ next
+ my set css.table-class list-tiny
+ my set css.tr.even-class even
+ my set css.tr.odd-class odd
+ }
+
+ Class create TABLE3::Action -superclass TABLE::Action
+ Class create TABLE3::Field -superclass TABLE::Field
+ Class create TABLE3::AnchorField -superclass TABLE::AnchorField
+ Class create TABLE3::ImageField -superclass TABLE::ImageField
}
Class TableWidget \
Index: openacs-4/packages/xotcl-core/tcl/context-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/context-procs.tcl,v
diff -u -r1.10 -r1.11
--- openacs-4/packages/xotcl-core/tcl/context-procs.tcl 7 Mar 2007 19:13:05 -0000 1.10
+++ openacs-4/packages/xotcl-core/tcl/context-procs.tcl 9 Mar 2007 11:02:56 -0000 1.11
@@ -50,6 +50,7 @@
}
# get the query parameters (from the url)
+ #my log "--P processing actual query $actual_query"
foreach querypart [split $actual_query &] {
set name_value_pair [split $querypart =]
set att_name [ns_urldecode [lindex $name_value_pair 0]]
Index: openacs-4/packages/xotcl-core/tcl/generic-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/generic-procs.tcl,v
diff -u -r1.45 -r1.46
--- openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 19 Feb 2007 10:03:35 -0000 1.45
+++ openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 9 Mar 2007 11:02:56 -0000 1.46
@@ -848,7 +848,39 @@
return [t1 asHTML]
}
+
#
+ # Object specific privilege to be used with policies
+ #
+
+ CrItem ad_instproc privilege=creator {
+ {-login true} user_id package_id
+ } {
+
+ Define an object specific privilege to be used in the policies.
+ Grant access to a content item for the creator (creation_user)
+ of the item, and for the package admin.
+
+ } {
+ set allowed 0
+ my log "--checking privilege [self args]"
+ if {[my exists creation_user]} {
+ if {$user_id == 0 && $login} {
+ auth::require_login
+ } elseif {[my set creation_user] == $user_id} {
+ set allowed 1
+ } else {
+ # allow the package admin always access
+ set allowed [::xo::cc permission \
+ -object_id $package_id \
+ -party_id $user_id \
+ -privilege admin]
+ }
+ }
+ return $allowed
+ }
+
+ #
# Form template class
#
Index: openacs-4/packages/xotcl-core/tcl/policy-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/policy-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/tcl/policy-procs.tcl 9 Mar 2007 11:02:56 -0000 1.1
@@ -0,0 +1,164 @@
+ad_library {
+ XOTcl API for policies
+
+ @author Gustaf Neumann
+ @creation-date 2007-03-09
+ @cvs-id $Id: policy-procs.tcl,v 1.1 2007/03/09 11:02:56 gustafn Exp $
+}
+
+namespace eval ::xo {
+
+ Class Policy
+
+ Policy instproc defined_methods {class} {
+ set c [self]::$class
+ expr {[my isclass $c] ? [$c array names require_permission] : [list]}
+ }
+
+ Policy instproc check_privilege {{-login true} privilege object method} {
+ set allowed -1 ;# undecided
+ if {[acs_user::site_wide_admin_p]} {
+ return 1
+ }
+ switch $privilege {
+ none {return 1}
+ login {
+ if {$login} {
+ auth::require_login; return 1
+ } else {
+ return [expr {[::xo::cc user_id] != 0}]
+ }
+ }
+ swa {
+ set allowed 0
+ #if {!$allowed} {
+ # ad_return_warning "Insufficient Permissions" \
+ # "Only side wide admins are allowed for this operation! ($object $method)"
+ # ad_script_abort
+ #}
+ }
+ default {
+ # try object specific privileges. These have the signature:
+ #
+ # instproc privilege= {{-login true} user_id package_id}
+ #
+ if {[$object info methods privilege=$privilege] ne ""} {
+ set allowed [$object privilege=$privilege \
+ -login $login [::xo::cc user_id] [::xo::cc package_id]]
+ }
+ }
+ }
+ #my log "--check_privilege {$privilege $object $method} ==> $allowed"
+ return $allowed
+ }
+
+ Policy instproc get_privilege {permission object method} {
+ # the privilege might by primitive (one word privilege)
+ # or it might be complex (attribute + privilege)
+ # or it might be conditional (primitive or complex) in a list of privilges
+
+ foreach p $permission {
+
+ set condition [lindex $p 0]
+ if {[llength $condition]>1} {
+ # we have a condition
+ if {[eval $object condition $method $condition]} {
+ # the condition is true
+ #my log "--c check cond=$condition == TRUE"
+ return [my get_privilege [lrange $p 1 end] $object $method]
+ }
+ } else {
+ # we have no condition
+ return [list [expr {[llength $p] == 1 ? "primitive" : "complex"}] $p]
+ }
+ }
+ }
+
+ Policy ad_instproc check_permissions {object method} {
+
+ This method checks whether the current user is allowed
+ or not to invoke a method based on the given policy.
+ This method is purely checking and does not force logins
+ or other side effects. It can be safely used for example
+ to check whether links should be shown or not.
+
+ @see enforce_permissions
+ @return 0 or 1
+
+ } {
+ foreach class [concat [$object info class] [[$object info class] info heritage]] {
+ set c [self]::[namespace tail $class]
+ if {![my isclass $c]} continue
+ set key require_permission($method)
+ if {[$c exists $key]} {
+ set permission [$c set $key]
+
+ foreach {kind p} [my get_privilege $permission $object $method] break
+ switch $kind {
+ primitive {return [my check_privilege -login false $p $object $method]}
+ complex {
+ foreach {attribute privilege} $p break
+ set id [$object set $attribute]
+ my log "--p checking permission::permission_p -object_id $id -privilege $privilege"
+ return [::xo::cc permission -object_id $id -privilege $privilege \
+ -party_id [xo::cc user_id]]
+ }
+ }
+ }
+ }
+ return 0
+ }
+
+ Policy ad_instproc enforce_permissions {object method} {
+
+ This method checks whether the current user is allowed
+ or not to invoke a method based on the given policy and
+ forces logins if required.
+
+ @see check_permissions
+ @return 0 or 1
+
+ } {
+ #my log "--p enforce_permissions {$object $method}"
+ set allowed 0
+ foreach class [concat [$object info class] [[$object info class] info heritage]] {
+ set c [self]::[namespace tail $class]
+ if {![my isclass $c]} continue
+ set key require_permission($method)
+ if {[$c exists $key]} {
+ set permission [$c set $key]
+
+ foreach {kind p} [my get_privilege $permission $object $method] break
+ switch $kind {
+ primitive {
+ set allowed [my check_privilege $p $object $method]
+ set privilege $p
+ break
+ }
+ complex {
+ foreach {attribute privilege} $p break
+ set id [$object set $attribute]
+ set allowed [::xo::cc permission -object_id $id \
+ -privilege $privilege \
+ -party_id [xo::cc user_id]]
+ break
+ }
+ }
+ }
+ }
+
+ #my log "--p enforce_permissions {$object $method} ==> $allowed"
+
+ if {!$allowed} {
+ ns_log notice "permission::require_permission: [::xo::cc user_id] doesn't \
+ have $privilege on $object"
+ ad_return_forbidden "Permission Denied" "
+ You don't have sufficient permissions for $method on this object ($object).
+
"
+ ad_script_abort
+ }
+
+ return $allowed
+ }
+
+}
\ No newline at end of file
Index: openacs-4/packages/xotcl-core/www/index.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/index.tcl,v
diff -u -r1.4 -r1.5
--- openacs-4/packages/xotcl-core/www/index.tcl 7 Jan 2007 21:35:38 -0000 1.4
+++ openacs-4/packages/xotcl-core/www/index.tcl 9 Mar 2007 11:02:56 -0000 1.5
@@ -64,7 +64,7 @@
append output "[::xotcl::api object_link {} $cl] "
- foreach kind {class superclass mixin instmixin} {
+ foreach kind {class superclass subclass mixin instmixin} {
append output [info_classes $cl $kind]
}