Index: openacs-4/packages/dynamic-types/tcl/00-event-init.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/dynamic-types/tcl/00-event-init.tcl,v
diff -u -N
--- openacs-4/packages/dynamic-types/tcl/00-event-init.tcl 26 May 2005 10:27:58 -0000 1.3
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,11 +0,0 @@
-ad_library {
-
- Initialise the event dispatcher nsv.
-
- @author Lee Denison (lee@thaum.net)
- @creation-date 2004-03-17
- @cvs-id $Id: 00-event-init.tcl,v 1.3 2005/05/26 10:27:58 maltes Exp $
-
-}
-
-nsv_set util_events lock [ns_mutex create]
Index: openacs-4/packages/dynamic-types/tcl/dynamic-type-init.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/dynamic-types/tcl/dynamic-type-init.tcl,v
diff -u -N
--- openacs-4/packages/dynamic-types/tcl/dynamic-type-init.tcl 26 May 2005 10:27:58 -0000 1.3
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,15 +0,0 @@
-ad_library {
- Register attribute callbacks.
-
- @author Lee Denison (lee@xarg.net)
- @creation-date 2004/11/11
- @cvs-id $Id: dynamic-type-init.tcl,v 1.3 2005/05/26 10:27:58 maltes Exp $
-}
-
-util::event::register -event dtype \
- -match { action (updated|deleted) } \
- { dtype::flush_cache -type $type -event event }
-
-util::event::register -event dtype.attribute \
- -match { action (created|updated|deleted) } \
- { dtype::flush_cache -type $type -event event }
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 -N -r1.6 -r1.7
--- openacs-4/packages/dynamic-types/tcl/dynamic-type-procs.tcl 7 Jul 2005 00:21:13 -0000 1.6
+++ openacs-4/packages/dynamic-types/tcl/dynamic-type-procs.tcl 7 Jul 2005 14:00:08 -0000 1.7
@@ -120,6 +120,7 @@
{-name:required}
{-drop_children:boolean}
{-drop_table:boolean}
+ {-no_flush:boolean}
} {
Delete a dynamically created content type.
} {
@@ -128,9 +129,9 @@
db_exec_plsql drop_type {}
- set event(object_type) $name
- set event(action) deleted
- util::event::fire -event dtype event
+ if {!$no_flush_p} {
+ dtype::flush_cache -type $name
+ }
}
ad_proc -public dtype::create_attribute {
@@ -141,6 +142,8 @@
{-pretty_plural ""}
{-sort_order ""}
{-default_value ""}
+ {-no_flush:boolean}
+
} {
Creates an attribute on a content type.
} {
@@ -162,10 +165,9 @@
db_exec_plsql create_attr {}
- set event(object_type) $object_type
- set event(attribute) $name
- set event(action) created
- util::event::fire -event dtype.attribute event
+ if {!$no_flush_p} {
+ dtype::flush_cache -type $name
+ }
}
ad_proc -public dtype::get_attributes {
@@ -242,15 +244,10 @@
ad_proc -private dtype::flush_cache {
{-type:required}
- {-event:required}
} {
Flushes the util_memoize cache of dtype calls for a given object type.
-
- event is assumed to contain object_type and action
} {
- upvar $event dtype_event
-
- util_memoize_flush_regexp "dtype::get_attributes_list -no_cache -name \"$dtype_event(object_type)\".*"
+ util_memoize_flush_regexp "dtype::get_attributes_list -no_cache -name \"$type\".*"
}
ad_proc -public dtype::edit_attribute {
@@ -259,15 +256,15 @@
{-pretty_name:required}
{-pretty_plural:required}
{-default_value ""}
+ {-no_flush:boolean}
} {
Sets the details of an attribute.
} {
db_dml update_attribute {}
- set event(object_type) $object_type
- set event(attribute) $name
- set event(action) updated
- util::event::fire -event dtype.attribute event
+ if {!$no_flush_p} {
+ dtype::flush_cache -type $name
+ }
}
ad_proc -public dtype::get_attribute {
@@ -284,17 +281,17 @@
{-name:required}
{-object_type:required}
{-drop_column:boolean}
+ {-no_flush:boolean}
} {
Drops an attribute on a content type.
} {
set drop_column [db_boolean $drop_column_p]
db_exec_plsql drop_attr {}
- set event(object_type) $object_type
- set event(attribute) $name
- set event(action) deleted
- util::event::fire -event dtype.attribute event
+ if {!$no_flush_p} {
+ dtype::flush_cache -type $name
+ }
}
Index: openacs-4/packages/dynamic-types/tcl/event-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/dynamic-types/tcl/event-procs.tcl,v
diff -u -N
--- openacs-4/packages/dynamic-types/tcl/event-procs.tcl 26 May 2005 10:27:58 -0000 1.3
+++ /dev/null 1 Jan 1970 00:00:00 -0000
@@ -1,151 +0,0 @@
-ad_library {
- A library which dispatches tcl callback events.
-
- Events are assigned heirarchical symbolic names, eg:
-
- major-type
- major-type.minor-type
- major-type.minor-type.leaf-type
-
- Event handlers register which types they respond to, eg:
-
- major-type
- - respond only to exact match 'major-type' events
-
- major-type.
- - respond to all 'major-type' and subtype events
-
- major-type.minor-type.
- - respond to only to 'major-type.minor-type' and subtype events
-
- When an event is triggered an array called 'event' is made available to
- the handler containing information about the event. At registration time
- a handler can specify criteria which must be matched in the event array
- for this handler to be triggered.
-
- Functions that fire events should document what information they include
- in the event array. They should normally include an action which is a
- verb in the past tense 'created' for events that have just happened or a
- verb in the present tense 'creating' for events that are about to happen.
-
- Most events won't need this level of flexibility but I did for the stuff
- I was doing when I wrote this.
-
- @author Lee Denison (lee@xarg.net)
- @creation-date 2004/11/11
- @cvs-id $Id: event-procs.tcl,v 1.3 2005/05/26 10:27:58 maltes Exp $
-}
-
-namespace eval util {}
-namespace eval util::event {}
-
-ad_proc -public util::event::register {
- {-event:required}
- {-match {}}
- script
-} {
- Registers script to be run on event if the
- criteria in match are satisfied.
-} {
- set handler [list $match $script]
-
- ns_mutex lock [nsv_get util_events lock]
- nsv_lappend util_events $event $handler
- ns_mutex unlock [nsv_get util_events lock]
-}
-
-ad_proc -public util::event::unregister {
- {-event:required}
- {-match {}}
- script
-} {
- Unregisters script from event event where the
- criteria in match are required.
-} {
- ns_mutex lock [nsv_get util_events lock]
- if {[nsv_exists util_events $event]} {
- set handlers [nsv_get util_events $event]
-
- set result [list]
- foreach handler $handlers {
- set cand_match [lindex $handler 0]
- set cand_script [lindex $handler 1]
-
- if {![string match $script $cand_scripts] ||
- ![util::event::compare_matches $match $cand_match]} {
- lappend result $handler
- }
- }
-
- nsv_set util_events $event $result
- }
- ns_mutex unlock [nsv_get util_events lock]
-}
-
-ad_proc -private util::event::compare_matches {
- match1
- match2
-} {
- Compares two match lists for equality.
-} {
- foreach crit1 $match1 {
- foreach crit2 $match2 {
- if {![string equal [lindex $crit1 0] [lindex $crit2 0]] ||
- ![string equal [lindex $crit1 1] [lindex $crit2 1]]} {
- return 0
- }
- }
- }
-
- return 1
-}
-
-ad_proc -public util::event::fire {
- {-event:required}
- data
-} {
- Fires any scripts registered to event for which the match criteria are
- satisfied.
-
- Each event script is executed with access to an event array containing the
- event data. Consult the documentation of the function that fires the
- fires the event to see what data is available in the event.
-} {
- set type $event
- set type_elms [split $event "."]
- set type_bins [list $event]
- unset event
-
- upvar $data event
-
- for {set i 0} {$i < [llength $type_elms]} {incr i} {
- lappend type_bins "[join [lrange $type_elms 0 $i] "."]."
- }
-
- set results [list]
-
- foreach type_bin $type_bins {
- if {[nsv_exists util_events $type_bin]} {
- set handlers [nsv_get util_events $type_bin]
-
- foreach handler $handlers {
- array set match [lindex $handler 0]
- set script [lindex $handler 1]
- set matches_p 1
-
- foreach key [array names match] {
- set matches_p \
- [expr {$matches_p ||
- [regexp -- $match($key) $event($key)]}]
-
- }
-
- if {$matches_p} {
- lappend results [eval $script]
- }
- }
- }
- }
-
- return $results
-}