Index: openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl,v diff -u -N -r1.72 -r1.72.2.1 --- openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 12 Aug 2013 20:01:05 -0000 1.72 +++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 15 Sep 2013 16:22:40 -0000 1.72.2.1 @@ -783,7 +783,137 @@ } } +proc ::xo::getObjectProperty {o what args} { + switch $what { + "mixin" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info mixin]} + return [$o info object mixin classes] + } + "instmixin" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info instmixin]} + return [$o info mixin classes] + } + "instproc" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info instprocs {*}args]} + return [$o info methods -type scripted {*}args] + } + "instcommand" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info instcommands {*}args]} + return [$o info methods {*}args] + } + "instforward" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info instforward {*}args]} + return [$o info methods -type forwarder {*}args] + } + "proc" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info procs {*}args]} + return [$o info object methods -type scripted {*}args] + } + "command" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info procs {*}args]} + return [$o info object methods {*}args] + } + "forward" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info forward {*}args]} + return [$o info object methods -type forwarder {*}args] + } + "slots" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info slots]} + return [$o info object methods -type forwarder] + } + "class" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info class]} + return [$o info class] + } + "superclass" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info superclass]} + return [$o info superclass] + } + "subclass" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info subclass]} + return [$o info subclass] + } + "parameter" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info parameter]} + set result "" + foreach p [$o info configure parameters] {lappend result [$o info parameter name $p]} + return $result + } + "isclass" { + if {[info command $o] eq ""} {return 0} + if {"::xotcl::Object" in [$o info precedence]} {return [expr {"::xotcl::Class" in [$o info precedence]}]} + return [nsf::is class $o] + } + "isobject" { + if {[info command $o] eq ""} {return 0} + if {"::xotcl::Object" in [$o info precedence]} {return 1} + return [nsf::is object $o] + } + "instargs" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info instargs {*}$args]} + return [$o info method args {*}$args] + } + "args" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info args {*}$args]} + return [$o info object method args {*}$args] + } + "instargdefault" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info instdefault {*}$args]} + set parameter [$o info method parameter [lindex $args 0]] + foreach p $parameter { + if {[llength $p]>1} { + lassign $p name default + } else { + lassign [list $p ""] name default + } + if {$name eq [lindex $args 1]} { + return $default + } + } + } + "argdefault" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o info default {*}$args]} + set parameter [$o info object method parameter [lindex $args 0]] + foreach p $parameter { + if {[llength $p]>1} { + lassign $p name default + } else { + lassign [list $p ""] name default + } + if {$name eq [lindex $args 1]} { + return $default + } + } + } + "array-exists" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o array exists {*}$args]} + return [$o eval [list array exists :{*}$args]] + } + "array-get" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o array get {*}$args]} + return [$o eval [list array get :{*}$args]] + } + "array-set" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o array set {*}$args]} + return [$o eval [list array set :{*}$args]] + } + "set" { + if {"::xotcl::Object" in [$o info precedence]} {return [$o set {*}$args]} + return [$o eval [list set :[lindex $args 0]]] + } + "isnxobject" { + if {[info command ::nsf::dispatch] ne "" && [info command $o] ne ""} { + return [::nsf::dispatch $o ::nsf::methods::object::info::hastype ::nx::Object] + } { + return 0 + } + } + default { + error "no idea how to return $what" + } + } +} #ns_log notice "*** FREECONN? [ns_ictl gettraces freeconn]" Index: openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl,v diff -u -N -r1.6.2.1 -r1.6.2.2 --- openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl 5 Sep 2013 11:49:13 -0000 1.6.2.1 +++ openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl 15 Sep 2013 16:22:40 -0000 1.6.2.2 @@ -33,7 +33,7 @@ if {[nsv_exists api_proc_doc $proc_index]} { return "$method" } else { - if {[$obj info ${kind}s $method] eq ""} { + if {[::xo::getObjectProperty $obj ${kind} $method] eq ""} { return $methodC } else { return $method @@ -42,12 +42,12 @@ } \ -proc isclass {scope obj} { expr {$scope eq "" ? - [::xotcl::Object isclass $obj] : - [$scope do ::xotcl::Object isclass $obj]} + [xo::getObjectProperty $obj isclass] : + [$scope do xo::getObjectProperty $obj isclass]} } -proc isobject {scope obj} { expr {$scope eq "" ? - [::xotcl::Object isobject $obj] : - [$scope do ::xotcl::Object isobject $obj]} + [xo::getObjectProperty $obj isobject] : + [$scope do xo::getObjectProperty $obj isobject]} } -proc scope {} { if {[info exists ::xotcl::currentThread]} { # we are in an xotcl thread; the body won't be accessible directly @@ -66,7 +66,7 @@ return $scope } -proc inscope {scope args} { - expr {$scope eq "" ? [eval $args] : [eval $scope do $args]} + expr {$scope eq "" ? [eval $args] : [$scope do {*}$args]} } -proc script_name {scope} { #set kind [expr {[my istype ::xotcl::Class] ? "Class" : "Object"}] @@ -149,15 +149,15 @@ ad_parse_documentation_string $doc doc_elements } set defaults [list] - foreach a [my info ${inst}args $proc_name] { - if {[my info ${inst}default $proc_name $a d]} {lappend defaults $a $d} + foreach a [::xo::getObjectProperty [self] ${inst}args $proc_name] { + if {[::xo::getObjectProperty [self] ${inst}argdefault $proc_name $a d]} {lappend defaults $a $d} } set public [expr {$private ? false : true}] set doc_elements(public_p) $public set doc_elements(private_p) $private set doc_elements(deprecated_p) $deprecated set doc_elements(warn_p) $deprecated - set doc_elements(varargs_p) [expr {"args" in [my info ${inst}args $proc_name]}] + set doc_elements(varargs_p) [expr {"args" in [::xo::getObjectProperty [self] ${inst}args $proc_name]}] set doc_elements(flags) [list] set doc_elements(switches) [list] foreach f [my info ${inst}nonposargs $proc_name] { @@ -175,7 +175,7 @@ lappend defaults $sw $default } set doc_elements(default_values) $defaults - set doc_elements(positionals) [my info ${inst}args $proc_name] + set doc_elements(positionals) [::xo::getObjectProperty [self] ${inst}args $proc_name] # argument documentation finished set scope [::xotcl::api scope] set doc_elements(script) [::xotcl::api script_name $scope] Index: openacs-4/packages/xotcl-core/www/show-class-graph.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/show-class-graph.tcl,v diff -u -N -r1.8 -r1.8.6.1 --- openacs-4/packages/xotcl-core/www/show-class-graph.tcl 3 Feb 2011 19:30:19 -0000 1.8 +++ openacs-4/packages/xotcl-core/www/show-class-graph.tcl 15 Sep 2013 16:22:40 -0000 1.8.6.1 @@ -23,7 +23,7 @@ set infokind $kind if {$kind eq "instproc"} {append infokind s} ::xotcl::api scope_from_object_reference scope e - foreach method [$e info $infokind] { + foreach method [xo::getObjectProperty $e $kind] { if {$documented_methods} { set proc_index [::xotcl::api proc_index $scope $e $kind $method] #my msg "check $method => [nsv_exists api_proc_doc $proc_index]" @@ -39,7 +39,11 @@ set definition "" append definition "[my dotquote $e] \[label=\"\{$e|" foreach slot [$e info slots] { - append definition "[$slot name]\\l" + set name "" + catch {set name $slot name} + if {$name ne ""} { + append definition "[$slot name]\\l" + } } append definition "|" ::xotcl::api scope_from_object_reference scope e @@ -102,15 +106,15 @@ append children "[my dotquote $c]->[my dotquote $e];\n" } } - set m [$e info mixin] + set m [xo::getObjectProperty $e mixin] #puts "-- $e mixin $m" if {$m eq ""} continue append mixins "[my dotquote $e]->[my dotquotel $m];\n" } set tclasses "" set instmixins "" foreach e $classes { - set m [$e info instmixin] + set m [xo::getObjectProperty $e instmixin] #puts "-- $e instmixin $m" if {$m eq ""} continue #foreach mixin $m { @@ -152,10 +156,13 @@ catch {set dot [::util::which dot]} # final ressort for cases, where ::util::which is not available if {$dot eq "" && [file executable /usr/bin/dot]} {set dot /usr/bin/dot} -if {$dot eq ""} {ns_return 404 plain/text "do dot found"; ad_script_abort} - +if {$dot eq ""} {ns_return 404 plain/text "dot dot found"; ad_script_abort} + set tmpnam [ns_tmpnam] set tmpfile $tmpnam.png +set f [open $tmpnam.dot w]; puts $f $dot_code; close $f + +#ns_log notice "png $tmpnam dot $tmpnam.dot" set f [open "|$dot -Tpng -o $tmpfile" w]; puts $f $dot_code; close $f ns_returnfile 200 [ns_guesstype $tmpfile] $tmpfile file delete $tmpfile Index: openacs-4/packages/xotcl-core/www/show-object.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/show-object.tcl,v diff -u -N -r1.15 -r1.15.6.1 --- openacs-4/packages/xotcl-core/www/show-object.tcl 2 Feb 2011 16:26:45 -0000 1.15 +++ openacs-4/packages/xotcl-core/www/show-object.tcl 15 Sep 2013 16:22:40 -0000 1.15.6.1 @@ -31,6 +31,8 @@ set title "[::xotcl::api object_link $scope $my_class] $object" set isclass [::xotcl::api isclass $scope $object] +set isnx [xo::getObjectProperty $object isnxobject] + set s [DO Serializer new] set dimensional_slider [ad_dimensional { @@ -77,21 +79,21 @@ proc info_option {scope object kind {dosort 0}} { upvar class_references class_references - if {$dosort} { - set list [lsort [DO $object info $kind]] - } else { - set list [DO $object info $kind] - } + + set isnx [xo::getObjectProperty $object isnxobject] + set list [DO xo::getObjectProperty $object $kind] + set list [DO xo::getObjectProperty $object $kind] + + if {$dosort} {set list [lsort $list]} + set refs [list] foreach e $list { - if {[DO $object isclass $e]} { - lappend refs [::xotcl::api object_link $scope $e] - } + lappend refs [::xotcl::api object_link $scope $e] } - if {[llength $refs]>0 && $list ne ""} { + if {[llength $refs] > 0 && $list ne ""} { append class_references "
  • $kind: [join $refs {, }]
    • \n" } - if {[llength $list]>0 && $list ne ""} { + if {[llength $list] > 0 && $list ne ""} { return " \\\n -$kind [list $list]" } return "" @@ -110,8 +112,8 @@ proc class_summary {c scope} { set result "" - set parameters [lsort [$c info parameter]] - append result "
    Meta-class:
    [::xotcl::api object_link $scope [$c info class]]
    \n" + set parameters [lsort [xo::getObjectProperty $c parameter]] + append result "
    Meta-class:
    [::xotcl::api object_link $scope [xo::getObjectProperty $c class]]
    \n" if {$parameters ne ""} { set pretty [list] foreach p $parameters { @@ -125,7 +127,7 @@ } append result "
    Parameter for instances:
    [join $pretty {, }]
    \n" } - set methods [lsort [$c info instcommands]] + set methods [lsort [xo::getObjectProperty $c instcommand]] set pretty [list] foreach m $methods { if {[info exists param($m)]} continue @@ -135,7 +137,7 @@ if {[llength $pretty]>0} { append result "
    Methods for instances:
    [join $pretty {, }]
    " } - set methods [lsort [$c info commands]] + set methods [lsort [xo::getObjectProperty $c command]] set pretty [list] foreach m $methods { if {![::xotcl::Object isobject ${c}::$m]} { @@ -177,15 +179,15 @@ if {$isclass} { append output "

    Class Hierarchy of $object

    " - #append output [superclass_hierarchy $object] append output [draw_as_tree [superclass_hierarchy $object $scope]] + #set class_hierarchy [ns_urlencode [concat $object [$object info heritage]]] # # compute list of classes with siblings set class_hierarchy [list] foreach c [$object info superclass] { if {$c eq "::xotcl::Object"} {continue} - eval lappend class_hierarchy [$c info subclass] + lappend class_hierarchy {*}[$c info subclass] } if {[llength $class_hierarchy]>5} {set class_hierarchy {}} eval lappend class_hierarchy [$object info heritage] @@ -228,9 +230,8 @@ if {$isclass} { append obj_create_source \ [info_option $scope $object superclass] \ - [info_option $scope $object parameter 1] \ - [info_option $scope $object instmixin] - info_option $scope $object subclass 1 + [info_option $scope $object instmixin] \ + [info_option $scope $object subclass 1] } append obj_create_source \ @@ -258,21 +259,21 @@ if {$show_methods} { append output "

    Methods

    \n" \n } -if {$show_variables} { +if {$show_variables && !$isnx} { set vars "" foreach v [lsort [DO $object info vars]] { - if {[DO $object array exists $v]} { - append vars "$object array set $v [list [DO $object array get $v]]\n" + if {[DO ::xo::getObjectProperty $object array-exists $v]} { + append vars "$object array set $v [list [DO ::xo::getObjectProperty $object array-get $v]]\n" } else { - append vars "$object set $v [list [DO $object set $v]]\n" + append vars "$object set $v [list [DO ::xo::getObjectProperty $object set $v]]\n" } } if {$vars ne ""} {