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
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/www/show-class-graph.tcl	20 Mar 2008 10:26:26 -0000	1.1
@@ -0,0 +1,121 @@
+ad_page_contract {
+  Show an xotcl class or object
+  
+  @author Gustaf Neumann
+  @cvs-id $Id: show-class-graph.tcl,v 1.1 2008/03/20 10:26:26 gustafn Exp $
+} -query {
+  {classes}
+}
+
+::xotcl::Object instproc dotquote {e} {
+  return \"$e\" 
+}
+::xotcl::Object instproc dotquotel {l} {
+  set result [list]
+  foreach e $l { lappend result \"$e\" }
+  return $result
+}
+::xotcl::Object instproc dotcode {{-omit_base_classes 1} things} {
+  set classes [list]
+  set objects [list]
+
+  foreach e $things {
+    if {![my isobject $e]} continue
+    if {$omit_base_classes && $e eq "::xotcl::Object" || $e eq "::xotcl::Class"} continue
+    lappend [expr {[my isclass $e] ? "classes" : "objects"}] $e
+  }
+  set instances ""
+  foreach e $things {
+    if {![my isobject $e]} continue
+    if {$omit_base_classes && $e eq "::xotcl::Object" || $e eq "::xotcl::Class"} continue
+    set c [$e info class]
+    if {$omit_base_classes && $c eq "::xotcl::Object" || $c eq "::xotcl::Class"} continue
+    append instances "[my dotquote $e]->[my dotquote $c];\n"
+  }
+  set superclasses ""
+  foreach e $classes {
+    if {![my isobject $e]} continue
+    if {$e eq "::xotcl::Object"} continue
+    set reduced_sc [list]
+    foreach sc [$e info superclass] {
+      if {$omit_base_classes && $sc eq "::xotcl::Object"
+	  || $sc eq "::xotcl::Class"} continue
+      lappend reduced_sc $sc
+    }
+    if {$reduced_sc eq {}} continue
+    append superclasses "[my dotquote $e]->[my dotquotel $reduced_sc];\n"
+  }
+  set children ""
+  set mixins ""
+  foreach e $things {
+    if {![my isobject $e]} continue
+    if {$omit_base_classes && $e eq "::xotcl::Object" || $e eq "::xotcl::Class"} continue
+    foreach c [$e info children] {
+      if {[lsearch $things $c] == -1} continue
+      append children "[my dotquote $c]->[my dotquote $e];\n"
+    }
+    set m [$e info mixin]
+    #puts "-- $e mixin $m"
+    if {$m eq ""} continue
+    append mixins "[my dotquote $e]->[my dotquotel $m];\n"
+  }
+  set instmixins ""
+  foreach e $classes {
+    set m [$e info instmixin]
+    #puts "-- $e instmixin $m"
+    if {$m eq ""} continue
+    append instmixins "[my dotquote $e]->[my dotquotel $m];\n"
+  }
+  set tclasses ""
+  foreach e $classes {
+    set p [$e info parameter]
+    if {$p eq ""} {
+      append tclasses "[my dotquote $e] \[label=\"\{$e|"
+    } else {
+      append tclasses "[my dotquote $e] \[label=\"\{$e|"
+      foreach x $p {
+        set x [lindex $x 0]
+	append tclasses "$x\\l"
+      }
+    }
+    append tclasses "|"
+    foreach i [lsort [$e info instprocs]] {
+      append tclasses "$i\\l"
+    }
+    append tclasses "\}\"\];"
+  }
+  #label = \".\\n.\\nObject relations of [self]\"
+  #edge \[dir=back, constraint=0\] \"::Decorate_Action\" -> \"::Action\";
+  set objects  [join [my dotquotel $objects] {; }]
+  set classes  [join [my dotquotel $classes] {; }]
+  set imcolor hotpink4
+
+  set font "fontname = \"Helvetica\",fontsize = 8,"
+  #set font "fontname = \"Bitstream Vera Sans\",fontsize = 8,"
+# rankdir = BT; labeldistance = 20;
+  return "digraph {
+   rankdir = BT;
+   node \[$font shape=record\]; $tclasses
+   edge \[arrawohead=empty\]; $superclasses
+   node \[color=Green,shape=ellipse,fontcolor=Blue, style=filled, fillcolor=darkseagreen1\]; $objects
+   edge \[color=Blue,style=dotted\]; $instances
+   edge \[color=pink,arrowhead=diamond, style=dotted\]; $children
+   edge \[label=instmixin,fontsize=10,color=$imcolor,fontcolor=$imcolor,arrowhead=none,arrowtail=vee, style=dashed,dir=back, constraint=0\]; $instmixins
+   edge \[label=mixin,fontsize=10,color=$imcolor,fontcolor=$imcolor,arrowhead=none,arrowtail=vee, style=dashed,dir=back, constraint=0\]; $mixins
+
+}"
+}
+
+set dot_code [::xotcl::Object dotcode $classes]
+set dot ""
+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"}
+
+set tmpfile [ns_tmpnam].png
+set f [open "|$dot  -Tpng -o $tmpfile" w]
+puts $f $dot_code
+close $f
+ns_returnfile 200 [ns_guesstype $tmpfile] $tmpfile
+file delete $tmpfile
\ No newline at end of file