Index: openacs-4/packages/xotcl-core/tcl/doc-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/doc-procs.tcl,v
diff -u
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/xotcl-core/tcl/doc-procs.tcl	1 May 2015 16:33:42 -0000	1.1
@@ -0,0 +1,195 @@
+ad_library {
+  generic doc procs
+
+  @creation-date 2015-04-30
+  @author Gustaf Neumann
+  @cvs-id $Id: doc-procs.tcl,v 1.1 2015/05/01 16:33:42 gustafn Exp $  
+}
+
+namespace eval ::xo {
+
+    proc dotquote {e} {
+	return \"$e\" 
+    }
+
+    proc dotquotel {l} {
+	set result [list]
+	foreach e $l { lappend result \"$e\" }
+	return $result
+    }
+    
+    ad_proc dot_append_method {{-documented_methods 1} e methods_ref kind} {
+    } {
+	upvar $methods_ref methods
+	set infokind $kind
+	if {$kind eq "instproc"} {append infokind s}
+	::xotcl::api scope_from_object_reference scope e
+	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]"
+		if {[nsv_exists api_proc_doc $proc_index]} {
+		    lappend methods $method
+		}
+	    } else {
+		lappend methods $method
+	    }
+	}
+    }
+    
+    ad_proc dotclass {{-is_focus 0} {-documented_methods 1} e} {
+    } {
+	set definition ""
+        if {$is_focus} {
+	    set style "style=filled,penwidth=1.5,color=bisque4,fillcolor=beige,"
+	} else {
+	    set style ""
+	}
+	set url [export_vars -base show-object [list [list object $e]]]
+	append definition "[dotquote $e] \[${style}URL=\"$url\",label=\"\{$e|"
+	foreach slot [$e info slots] {
+	    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
+	set methods [list]
+	dot_append_method -documented_methods $documented_methods $e methods instproc
+	dot_append_method -documented_methods $documented_methods $e methods instforward
+	foreach method [lsort $methods] {append definition "$method\\l" }
+	append definition "\}\"\];\n"
+    }
+
+    ad_proc dotobject {e} {
+    } {
+	set url [export_vars -base show-object [list [list object $e]]]
+     	set definition "[dotquote $e] \[URL=\"$url\"\];\n";
+    }
+
+    ad_proc dotcode {
+	{-with_children 0}
+	{-with_instance_relations 0} 
+	{-omit_base_classes 1} 
+	{-documented_methods 1}
+	{-current_object ""} 	
+	{-dpi 96} 
+	things
+    } {
+    } {
+	set classes {}
+	set objects {}
+	set iclasses {}
+	set mclasses {}
+	
+	foreach e $things {
+	    if {![::xotcl::Object isobject $e]} continue
+	    if {$omit_base_classes && ($e eq "::xotcl::Object" || $e eq "::xotcl::Class")} continue
+	    lappend [expr {[::xotcl::Object isclass $e] ? "classes" : "objects"}] $e
+	}
+	set instances ""
+	if {$with_instance_relations} {
+	    foreach e $things {
+		if {![::xotcl::Object 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
+		if {$c ni $things} {lappend iclasses $c}
+		append instances "[dotquote $e]->[dotquote $c];\n"
+	    }
+	}
+	set superclasses ""
+	foreach e $classes {
+	    if {![::xotcl::Object isobject $e]} continue
+	    if {$e eq "::xotcl::Object"} continue
+	    set reduced_sc [list]
+	    foreach sc [::xo::getObjectProperty $e superclass] {
+		if {$omit_base_classes && ($sc eq "::xotcl::Object" || $sc eq "::xotcl::Class")} continue
+		lappend reduced_sc $sc
+	    }
+	    if {$reduced_sc eq {}} continue
+	    foreach sc $reduced_sc {
+		if {$sc in $things} {
+		    append superclasses "[dotquote $e]->[dotquotel $sc];\n"
+		}
+	    }
+	}
+	set children ""
+	set mixins ""
+	foreach e $things {
+	    if {![::xotcl:::Object isobject $e]} continue
+	    if {$omit_base_classes && ($e eq "::xotcl::Object" || $e eq "::xotcl::Class")} continue
+	    if {$with_children} {
+		foreach c [$e info children] {
+		    if {$c ni $things} continue
+		    append children "[dotquote $c]->[dotquote $e];\n"
+		}
+	    }
+	    set m [xo::getObjectProperty $e mixin]
+	    #puts "-- $e mixin $m"
+	    if {$m eq ""} continue
+	    foreach mixin $m {
+		if {$mixin ni $things} {lappend mclasses $m}
+		append mixins "[dotquote $e]->[dotquotel $mixin];\n"
+	    }
+	}
+	set tclasses ""
+	set instmixins ""
+	foreach e $classes {
+	    set m [xo::getObjectProperty $e instmixin]
+	    #puts "-- $e instmixin $m"
+	    if {$m eq ""} continue
+	    #foreach mixin $m {
+	    #  append tclasses [dotclass -documented_methods $documented_methods $mixin]
+	    #}
+
+	    foreach mixin $m {
+		if {$mixin ni $things} {lappend mclasses $mixin}
+		append instmixins "[dotquote $e]->[dotquotel $mixin];\n"
+	    }
+	}
+
+	foreach e $classes {
+	    append tclasses [dotclass -is_focus [expr {$e eq $current_object}] -documented_methods $documented_methods $e]
+	}
+	set tobjects {}
+	foreach e $objects {
+	    append tobjects [dotobject $e]
+	}
+	set tmclasses {}
+	foreach e $mclasses {
+	    append tmclasses [dotobject $e]
+	}
+	set ticlasses {}
+	foreach e $iclasses {
+	    append ticlasses [dotobject $e]
+	}
+
+	#label = \".\\n.\\nObject relations of [self]\"
+	#edge \[dir=back, constraint=0\] \"::Decorate_Action\" -> \"::Action\";
+	set objects  [join [dotquotel $objects] {; }]
+	#set classes  [join [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 {
+   dpi = $dpi;
+   rankdir = BT;
+   node \[$font shape=record\]; $tclasses
+   edge \[arrowhead=empty\]; $superclasses
+   node \[fontcolor=$imcolor, color=$imcolor, style=filled, fillcolor=bisque\]; $tmclasses
+   node \[fontcolor=blue, color=blue, style=filled, fillcolor=darkslategray2\]; $ticlasses
+   node \[color=Green,shape=ellipse,fontcolor=Blue, style=filled, fillcolor=darkseagreen1\]; $tobjects
+   edge \[color=Blue,style=dotted,arrowhead=normal,label=\"instance of\",fontsize=10\]; $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
+
+}"
+    }
+
+}
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 -r1.9 -r1.10
--- openacs-4/packages/xotcl-core/www/show-class-graph.tcl	27 Oct 2014 16:42:02 -0000	1.9
+++ openacs-4/packages/xotcl-core/www/show-class-graph.tcl	1 May 2015 16:33:42 -0000	1.10
@@ -8,148 +8,11 @@
   {documented_only 1}
   {with_children 0}
   {dpi 96}
+  {format png}
 }
 
-::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 dot_append_method {{-documented_methods 1} e methods_ref kind} {
-  my upvar $methods_ref methods
-  set infokind $kind
-  if {$kind eq "instproc"} {append infokind s}
-  ::xotcl::api scope_from_object_reference scope e
-  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]"
-      if {[nsv_exists api_proc_doc $proc_index]} {
-        lappend methods $method
-      }
-    } else {
-      lappend methods $method
-    }
-  }
-}
-::xotcl::Object instproc dotclass {{-documented_methods 1} e} {
-  set definition ""
-  append definition "[my dotquote $e] \[label=\"\{$e|"
-  foreach slot [$e info slots] {
-    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
-  set methods [list]
-  my dot_append_method -documented_methods $documented_methods $e methods instproc
-  my dot_append_method -documented_methods $documented_methods $e methods instforward
-  foreach method [lsort $methods] {
-    append definition "$method\\l"
-  }
-  append definition "\}\"\];\n"
-}
 
-
-::xotcl::Object instproc dotcode {
-  {-with_children 0} 
-  {-omit_base_classes 1} 
-  {-documented_methods 1} 
-  {-dpi 96} 
-  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 [::xo::getObjectProperty $e superclass] {
-      if {$omit_base_classes && $sc eq "::xotcl::Object"
-          || $sc eq "::xotcl::Class"} continue
-      lappend reduced_sc $sc
-    }
-    if {$reduced_sc eq {}} continue
-    foreach sc $reduced_sc {
-      append superclasses "[my dotquote $e]->[my dotquotel $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
-    if {$with_children} {
-      foreach c [$e info children] {
-        if {$c ni $things} continue
-        append children "[my dotquote $c]->[my dotquote $e];\n"
-      }
-    }
-    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 [xo::getObjectProperty $e instmixin]
-    #puts "-- $e instmixin $m"
-    if {$m eq ""} continue
-    #foreach mixin $m {
-    #  append tclasses [my dotclass -documented_methods $documented_methods $mixin]
-    #}
-    append instmixins "[my dotquote $e]->[my dotquotel $m];\n"
-  }
-
-  foreach e $classes {
-    append tclasses [my dotclass -documented_methods $documented_methods $e]
-  }
-  #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 {
-   dpi = $dpi;
-   rankdir = BT;
-   node \[$font shape=record\]; $tclasses
-   edge \[arrowhead=empty\]; $superclasses
-   node \[color=Green,shape=ellipse,fontcolor=Blue, style=filled, fillcolor=darkseagreen1\]; $objects
-   edge \[color=Blue,style=dotted,arrowhead=normal,label=\"instance of\",fontsize=10\]; $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 -dpi $dpi \
+set dot_code [::xo::dotcode -dpi $dpi \
                   -with_children $with_children -documented_methods $documented_only \
                   $classes]
 set dot ""
@@ -159,11 +22,11 @@
 if {$dot eq ""} {ns_return 404 plain/text "dot not found"; ad_script_abort}
  
 set tmpnam [ad_tmpnam]
-set tmpfile $tmpnam.png
-set f [open $tmpnam.dot w]; puts $f $dot_code; close $f
+set tmpfile $tmpnam.$format
+set f [open $tmpnam.$format 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
+set f [open "|$dot  -T$format -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.adp
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/show-object.adp,v
diff -u -r1.6 -r1.7
--- openacs-4/packages/xotcl-core/www/show-object.adp	27 Oct 2014 16:42:02 -0000	1.6
+++ openacs-4/packages/xotcl-core/www/show-object.adp	1 May 2015 16:33:43 -0000	1.7
@@ -1,20 +1,17 @@
 <master>
-<!-- <property name="doc(title)">@title;noquote@</property>-->
 <property name="doc(title)">@title;noquote@</property>
-<property name="doc(title)">@title;noquote@</property>
 <property name="context">@context;noquote@</property>
-<property name="header_stuff">
 <style>
 pre.code {
         font-size: 80%;
         font-family: courier, monospace;
-        PADDING-RIGHT: 10px;
-        PADDING-LEFT: 10px;
-        PADDING-BOTTOM: 10px;
-        PADDING-TOP: 10px;
-        BORDER: #cccccc 1px solid;
-        BACKGROUND-COLOR: #eeeeee;
-        MARGIN-BOTTOM: 15px;
+        padding-right: 10px;
+        padding-left: 10px;
+        padding-bottom: 10px;
+        padding-top: 10px;
+        border: #cccccc 1px solid;
+        background-color: #eeeeee;
+        margin-bottom: 15px;
 }
 pre em {
         font-family: cursive;
@@ -38,7 +35,12 @@
 
 <h1 class="page-title">@title;noquote@</h1>
 <if @class_hierarchy@ not nil>
+<if @svg@ not nil>
+@svg;literal@
+</if>
+<else>
 <img style='float: right; max-width: 800px;' src='./show-class-graph?classes=@class_hierarchy@&documented_only=@documented_only@'>
+</else>
 </if>
 @output;noquote@
 
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 -r1.16 -r1.17
--- openacs-4/packages/xotcl-core/www/show-object.tcl	27 Oct 2014 16:42:02 -0000	1.16
+++ openacs-4/packages/xotcl-core/www/show-object.tcl	1 May 2015 16:33:43 -0000	1.17
@@ -2,19 +2,24 @@
   Show an xotcl class or object
   
   @author Gustaf Neumann
-  @cvs-id $id:$
+  @cvs-id $Id$
 } -query {
   {object:optional ::xotcl::Object}
   {show_methods:optional 1}
   {show_source:optional 0}
   {show_variables:optional 0}
+  {as_img:boolean 0}
+  {with_children:boolean 0}
+  {with_instance_relations:boolean 0}
+  {above:naturalnum 1}
+  {below:naturalnum 2}
 } -properties {
   title:onevalue
   context:onevalue
   output:onevalue
 }
 
-set context [list "XOTcl"]
+set context [list "XOTcl Object"]
 set output ""
 
 ::xotcl::api scope_from_object_reference scope object
@@ -167,16 +172,9 @@
   return "<strong> [::xotcl::api object_link $scope $c] </strong> $result"
 }
 
-proc reverse list {
-  set result [list]
-  for {set i [expr {[llength $list] - 1}]} {$i >= 0} {incr i -1}      {
-    lappend result [lindex $list $i]
-  }
-  return $result
-}
 proc superclass_hierarchy {cl scope} {
   set l [list]
-  foreach c [reverse [concat $cl [DO $cl info heritage]]] {
+  foreach c [lreverse [concat $cl [DO $cl info heritage]]] {
     lappend s [class_summary $c $scope]
   }
   return $s
@@ -189,10 +187,17 @@
 append output "<blockquote>\n"
 
 if {$isclass} {
-  append output "<h4>Class Hierarchy of $object</h4>"
-  append output [draw_as_tree [superclass_hierarchy $object $scope]]
+  set hierarchy 0
+  if {$hierarchy} {
+    append output "<h4>Class Hierarchy of $object</h4>"
+    append output [draw_as_tree [superclass_hierarchy $object $scope]]
+  } else {
+    append output "</blockquote>\n"
+    append output "<h4>Class $object</h4>"
+    append output "<blockquote>\n"
+    append output [class_summary $object $scope]
+  }
 
-  #set class_hierarchy [ns_urlencode [concat $object [$object info heritage]]]
   #
   # compute list of classes with siblings
   set class_hierarchy [list]
@@ -201,12 +206,32 @@
     lappend class_hierarchy {*}[DO xo::getObjectProperty $c subclass]
   }
   if {[llength $class_hierarchy]>5} {set class_hierarchy {}}
-  lappend class_hierarchy {*}[DO $object info heritage]
+
+  # Display just up to two extra two levels of heritage to keep the
+  # class in quesiton in focus.
+  set heritage [DO $object info heritage]
+  if {[llength $heritage]>$above} {
+    set heritage [lrange $heritage 0 $above-1]
+  }
+  lappend class_hierarchy {*}$heritage
+  
   if {$object ni $class_hierarchy} {lappend class_hierarchy $object}
-  #::xotcl::Object msg class_hierarchy=$class_hierarchy
-  set class_hierarchy [ns_urlencode $class_hierarchy]
+
+  if {$below > 0} {
+    set subclasses [DO $object info subclass]
+    for {set level 1} {$level < $below} {incr level} {
+      foreach sc $subclasses {
+        foreach c [DO $sc info subclass] {
+          if {$c ni $subclasses} {
+            lappend subclasses $c
+          }
+        }
+      }
+    }
+    lappend class_hierarchy {*}$subclasses
+  }
+  
   set documented_only [expr {$show_methods < 2}]
-  #set class_hierarchy [ns_urlencode [concat $object [$object info heritage]]]
 }
 
 if {[nsv_exists api_library_doc $index]} {
@@ -263,7 +288,6 @@
 if {$class_references ne ""} {
   append output "<h4>Class Relations</h4><ul>\n$class_references</ul>\n"
 }
-append output "</blockquote>\n"
 
 if {$show_source} {
   append output [::xotcl::api source_to_html $obj_create_source] \n
@@ -342,7 +366,51 @@
   }
 }
 
+if {!$as_img} {
+  #
+  # Construct the dot code from the provided classes.
+  #
+  # TODO: it would be nice to pass the selected options from the
+  # dimensional slide to dotcode, since with svg, the dot code
+  # constructs URLS for navigation in the class tree.
+  #
+  set dot_code [::xo::dotcode -dpi 72 \
+                    -with_children $with_children \
+                    -with_instance_relations $with_instance_relations \
+                    -omit_base_classes 0 \
+                    -current_object $object \
+                    -documented_methods $documented_only \
+                    $class_hierarchy]
 
+  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 "dot not found"; ad_script_abort}
+ 
+  set tmpnam [ad_tmpnam]
+  set tmpfile $tmpnam.svg
+  set f [open $tmpnam.dot w]; puts $f $dot_code; close $f
+
+  #ns_log notice "svg $tmpnam dot $tmpnam.dot"
+  set f [open "|$dot  -Tsvg -o $tmpfile" w]; puts $f $dot_code; close $f
+  set f [open  $tmpfile]; set svg [read $f]; close $f
+
+  # delete the first three lines generated from dot
+  regsub {^[^\n]+\n[^\n]+\n[^\n]+\n} $svg "" svg
+  set css {
+    svg g a:link {text-decoration: none;}
+    div.inner {width: 100%; margin: 0 auto;}
+  }
+  set svg "<style>$css</style><div><div class='inner'>$svg</div></div>"
+
+  file delete $tmpfile
+  file delete $tmpnam.dot
+}
+
+append output "</blockquote>\n"
+
+
 DO $s destroy
 
 #