Index: openacs-4/packages/xotcl-core/COPYRIGHT =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/COPYRIGHT,v diff -u -N --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ openacs-4/packages/xotcl-core/COPYRIGHT 30 Dec 2005 00:04:44 -0000 1.1 @@ -0,0 +1,23 @@ + * xotcl-core + * + * Copyright (C) 2005 Gustaf Neumann, neumann@wu-wien.ac.at + * + * Vienna University of Economics and Business Administration + * Institute of Information Systems and New Media + * A-1090, Augasse 2-6 + * Vienna, Austria + * + * This is a BSD-Style license applicable for the files in this + * directory and below, except when stated explicitly different. + * + * Permission to use, copy, modify, distribute, and sell this + * software and its documentation for any purpose is hereby granted + * without fee, provided that the above copyright notice appear in + * all copies and that both that copyright notice and this permission + * notice appear in supporting documentation. We make no + * representations about the suitability of this software for any + * purpose. It is provided "as is" without express or implied + * warranty. + * + + 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 -N -r1.3 -r1.4 --- openacs-4/packages/xotcl-core/xotcl-core.info 15 Dec 2005 12:05:42 -0000 1.3 +++ openacs-4/packages/xotcl-core/xotcl-core.info 30 Dec 2005 00:04:44 -0000 1.4 @@ -8,10 +8,10 @@ t xotcl - + Gustaf Neumann XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes) - 2005-12-15 + 2005-12-29 This component contains some core functionality for OACS applications using XOTcl. It includes XOTcl thread handling for OACS (supporting persistent and @@ -25,7 +25,7 @@ when components are reloaded. 0.23 contains a major overhaul of the Generic classes. Object preliminary object layer for content repository, oo templating. 0 - + Index: openacs-4/packages/xotcl-core/tcl/05-doc-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/Attic/05-doc-procs.tcl,v diff -u -N -r1.4 -r1.5 --- openacs-4/packages/xotcl-core/tcl/05-doc-procs.tcl 15 Dec 2005 12:16:34 -0000 1.4 +++ openacs-4/packages/xotcl-core/tcl/05-doc-procs.tcl 30 Dec 2005 00:04:44 -0000 1.5 @@ -58,7 +58,7 @@ #set kind [expr {[my istype ::xotcl::Class] ? "Class" : "Object"}] #return "$scope$kind [self]" set script [info script] - if {[string equal "" $script] && [info exists ::xotcl::currentScript]} { + if {$script eq "" && [info exists ::xotcl::currentScript]} { set script $::xotcl::currentScript } set root_dir [nsv_get acs_properties root_directory] @@ -84,7 +84,7 @@ return "$scope$kind $obj" } -proc proc_index {scope obj instproc proc_name} { - if {[string equal "" $scope]} { + if {$scope eq ""} { return "$obj $instproc $proc_name" } else { return "$scope $obj $instproc $proc_name" Index: openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl,v diff -u -N -r1.4 -r1.5 --- openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl 15 Dec 2005 12:16:34 -0000 1.4 +++ openacs-4/packages/xotcl-core/tcl/10-recreation-procs.tcl 30 Dec 2005 00:04:44 -0000 1.5 @@ -154,7 +154,8 @@ #my log "+++ $obj recreate calling searchDefaults" $pcl searchDefaults $obj #my log "+++ $obj recreate calling $obj configure $args" - set pos [eval $obj configure $args] + # we use uplevel to handle -volatile correctly + set pos [my uplevel $obj configure $args] #my log "+++ recreate instproc configure returns $pos" if {[lsearch -exact $args -init] == -1} { incr pos -1 Index: openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl,v diff -u -N -r1.3 -r1.4 --- openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl 15 Dec 2005 12:16:34 -0000 1.3 +++ openacs-4/packages/xotcl-core/tcl/20-Ordered-Composite-procs.tcl 30 Dec 2005 00:04:44 -0000 1.4 @@ -55,7 +55,10 @@ OrderedComposite instproc destroy {} { # destroy all children of the ordered composite - foreach c [my set __children] { $c destroy } + if {[my exists __children]} { + #my log "-- destroying children [my set __children]" + foreach c [my set __children] { $c destroy } + } next } 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 -N -r1.3 -r1.4 --- openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 15 Dec 2005 12:16:34 -0000 1.3 +++ openacs-4/packages/xotcl-core/tcl/30-widget-procs.tcl 30 Dec 2005 00:04:44 -0000 1.4 @@ -34,6 +34,13 @@ Class Table -superclass OrderedComposite \ -parameter {{no_data "No Data"} {renderer TABLE2}} + Table instproc destroy {} { + #my log "-- " + foreach c {__actions __columns} { + namespace eval [self]::$c {namespace forget [self class]::*} + } + next + } Table instproc actions {cmd} { set M [OrderedComposite create [self]::__actions] namespace eval $M {namespace import -force [self class]::*} @@ -48,21 +55,26 @@ eval lappend slots [$c get-slots] } my proc add $slots { - set __self [Object new] + set __self [::xo::Table::Line new] foreach __v [info vars] {$__self set $__v [set $__v]} next $__self } } Table instproc render_with {renderer} { - #my log "--" + my log "--" set cl [self class] [self] mixin ${cl}::$renderer foreach child [$cl info classchildren] { #my log "-- $child heritage [$child info heritage]" if {[$child info heritage ::xo::OrderedComposite::Child] eq ""} continue - $child instmixin ${cl}::${renderer}::[namespace tail $child] - #my log "-- $child instmixin ${cl}::${renderer}::[namespace tail $child]" + set mixinname ${cl}::${renderer}::[namespace tail $child] + if {[::xotcl::Object isclass $mixinname]} { + $child instmixin $mixinname + #my log "-- using mixin $mixinname" + } else { + #my log "-- no mixin $mixinname" + } } my init_renderer } @@ -86,6 +98,18 @@ ns_return 200 text/csv $output } + Class create Table::Line \ + -instproc attlist {name atts {extra ""}} { + set result [list] + foreach att $atts { + set varname $name.$att + if {[my exists $varname]} {lappend result $att [my set $varname]} + } + foreach {att val} $extra {lappend result $att $val} + return $result + } + + # # Define elements of a Table # @@ -113,9 +137,43 @@ } return $slots } - + + Class ImageField \ + -parameter {src width height border title alt} \ + -superclass ::xo::Table::Field \ + -instproc get-slots {} { + set slots [list -[my name]] + lappend slots [list -[my name].src [my src]] + lappend slots [list -[my name].href ""] + foreach att {width height border title alt} { + if {[my exists $att]} { + lappend slots [list -[my name].$att [my $att]] + } else { + lappend slots [list -[my name].$att] + } + } + return $slots + } + + Class ImageField_EditIcon \ + -superclass ImageField -parameter { + {src /resources/acs-subsite/Edit16.gif} {width 16} {height 16} {border 0} + {title "Edit Item"} {alt "edit"} + } + Class ImageField_ViewIcon \ + -superclass ImageField -parameter { + {src /resources/acs-subsite/Zoom16.gif} {width 16} {height 16} {border 0} + {title "View Item"} {alt "view"} + } + Class ImageField_DeleteIcon \ + -superclass ImageField -parameter { + {src /resources/acs-subsite/Delete16.gif} {width 16} {height 16} {border 0} + {title "Delete Item"} {alt "delete"} + } + # export table elements - namespace export Field AnchorField Action + namespace export Field AnchorField Action ImageField \ + ImageField_EditIcon ImageField_ViewIcon ImageField_DeleteIcon } } @@ -244,6 +302,14 @@ next } + + Class create TABLE::ImageField \ + -superclass TABLE::Field \ + -instproc render-data {line} { + html::a -href [$line set [my name].href] -style "border-bottom: none;" { + html::img [$line attlist [my name] {src width height border title alt}] {} + } + } Class TABLE2 \ -superclass TABLE \ @@ -269,6 +335,7 @@ Class create TABLE2::Action -superclass TABLE::Action Class create TABLE2::Field -superclass TABLE::Field Class create TABLE2::AnchorField -superclass TABLE::AnchorField + Class create TABLE2::ImageField -superclass TABLE::ImageField } 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 -N -r1.4 -r1.5 --- openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 15 Dec 2005 12:16:34 -0000 1.4 +++ openacs-4/packages/xotcl-core/tcl/generic-procs.tcl 30 Dec 2005 00:04:44 -0000 1.5 @@ -221,7 +221,6 @@ } CrClass instproc init {} { - my log "-- " my instvar object_type sql_attribute_names if {[my info superclass] ne "::Generic::CrItem"} { my set superclass [[my info superclass] set object_type] @@ -231,7 +230,7 @@ foreach att [$o children] { lappend sql_attribute_names [$att attribute_name] } - my log "-- attribute_names <$sql_attribute_names> [$o info children]" + #my log "-- attribute_names <$sql_attribute_names> [$o info children]" if {![my object_type_exists]} { my create_object_type @@ -240,7 +239,6 @@ select tree_sortkey from acs_object_types where object_type = :object_type }] - my log "-- type key = [my set object_type_key]" next } @@ -334,6 +332,8 @@ {-with_subtypes:boolean true} {-count:boolean false} {-folder_id} + {-page_size 20} + {-page_number ""} } { returns the SQL-query to select the CrItems of the specified object_type @select_attributes attributes for the sql query to be retrieved, in addion @@ -357,17 +357,29 @@ "acs_object_types.tree_sortkey between \ '$object_type_key' and tree_right('$object_type_key')" : "acs_object_types.tree_sortkey = '$object_type_key'"}] - set attribute_selection [expr {$count ? "count(*)" : [join $attributes ,]}] + if {$count} { + set attribute_selection "count(*)" + set order_clause "" ;# no need to order when we count + set page_number "" ;# no pagination when count is used + } else { + set attribute_selection [join $attributes ,] + } + if {$where_clause ne ""} { set where_clause "and $where_clause" } + if {$page_number ne ""} { + set pagination "offset [expr {$page_size*($page_number-1)}] limit $page_size" + } else { + set pagination "" + } return "select $attribute_selection from acs_object_types, acs_objects, cr_items ci, cr_revisions cr where $type_selection and acs_object_types.object_type = ci.content_type and ci.live_revision = cr.revision_id - and parent_id = $folder_id - and acs_objects.object_id = cr.revision_id $where_clause $order_clause" + and parent_id = $folder_id and acs_objects.object_id = cr.revision_id \ + $where_clause $order_clause $pagination" } CrClass ad_instproc instantiate_all { @@ -376,13 +388,15 @@ {-where_clause ""} {-with_subtypes:boolean true} {-folder_id} + {-page_size 20} + {-page_number ""} } { Return all instances of an content type class matching the specified clauses. } { set __result [::xo::OrderedComposite new] uplevel #1 [list $__result volatile] - $__result proc destroy {} {my log "-- "; next} + #$__result proc destroy {} {my log "-- "; next} set __attributes [list] foreach a [concat [list ci.item_id acs_objects.object_type] \ @@ -396,7 +410,8 @@ -select_attributes $select_attributes \ -with_subtypes $with_subtypes \ -where_clause $where_clause \ - -order_clause $order_clause] { + -order_clause $order_clause \ + -page_size $page_size -page_number $page_number] { set __o [$object_type create ${__result}::$item_id] $__result add $__o #my log "-- $__result add $__o, $object_type $item_id" @@ -424,7 +439,7 @@ } { db_1row get_class "select content_type as object_type from cr_items \ where item_id=$item_id" - if {![string match ::* $object_type]} {set object_type ::$object_type} + if {![string match "::*" $object_type]} {set object_type ::$object_type} set o [$object_type create ::[expr {$revision_id ? $revision_id : $item_id}]] $object_type fetch_object \ -item_id $item_id -revision_id $revision_id -object $o Index: openacs-4/packages/xotcl-core/tcl/thread_mod-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/Attic/thread_mod-procs.tcl,v diff -u -N -r1.4 -r1.5 --- openacs-4/packages/xotcl-core/tcl/thread_mod-procs.tcl 15 Dec 2005 12:16:34 -0000 1.4 +++ openacs-4/packages/xotcl-core/tcl/thread_mod-procs.tcl 30 Dec 2005 00:04:44 -0000 1.5 @@ -132,7 +132,7 @@ it reinitializes the thread according to the new definition. } { my log "recreating [self] $obj, tid [$obj exists tid]" - if {![string match ::* $obj]} { set obj ::$obj } + if {![string match "::*" $obj]} { set obj ::$obj } $obj set recreate 1 next $obj init [lindex $args 0] @@ -231,11 +231,11 @@ # ::xotcl::THREAD::Proxy configure \ # -instproc forward args { # set cp [self calledproc] -# if { [string equal $cp attach] -# || [string equal $cp filter] -# || [string equal $cp detachAll]} { +# if { [string equal $cp "attach"] +# || $cp eq "filter" +# || $cp eq "detachAll"} { # next -# } elseif {[string equal $cp destroy]} { +# } elseif {$cp eq "destroy"} { # eval [my attach] do [self] $cp $args # my log "destroy" # next 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 -N -r1.1 -r1.2 --- openacs-4/packages/xotcl-core/www/index.tcl 11 Oct 2005 08:41:18 -0000 1.1 +++ openacs-4/packages/xotcl-core/www/index.tcl 30 Dec 2005 00:04:45 -0000 1.2 @@ -26,7 +26,7 @@ proc local_link cl { upvar all_classes all_classes - if {$all_classes || ![string match ::xotcl::* $cl]} { + if {$all_classes || ![string match "::xotcl::*" $cl]} { return "$cl" } else { return $cl @@ -50,7 +50,7 @@ append infos [local_link $s] ", " } set infos [string trimright $infos ", "] - if {[string compare "" $infos]} { + if {$infos ne ""} { return "
  • $key $infos
    • \n" } else { return "" @@ -59,7 +59,7 @@ set output "