xo::dotcode (private)

 xo::dotcode [ -with_children with_children ] \
    [ -with_instance_relations with_instance_relations ] \
    [ -omit_base_classes omit_base_classes ] \
    [ -documented_methods documented_methods ] \
    [ -hide_methods hide_methods ] [ -current_object current_object ] \
    [ -dpi dpi ] things

Defined in packages/xotcl-core/tcl/doc-procs.tcl

Switches:

-with_children (optional, defaults to "0")

-with_instance_relations (optional, defaults to "0")

-omit_base_classes (optional, defaults to "1")

-documented_methods (optional, defaults to "1")

-hide_methods (optional, defaults to "1")

-current_object (optional)

-dpi (optional, defaults to "96")

Parameters:

things (required)

Partial Call Graph (max 5 caller/called nodes):

Testcases:

No testcase defined.

Source code:

        set classes {}
        set objects {}
        set iclasses {}
        set mclasses {}

        foreach e $things {
            if {![::nsf::is object $e]
                || ($omit_base_classes && [::nsf::is baseclass $e])
            } continue
            lappend [expr {[::nsf::is class $e] ? "classes" : "objects"}] $e
        }
        set instances ""
        if {$with_instance_relations} {
            foreach e $things {
                if {![::nsf::is object $e]
                    || ($omit_base_classes && [::nsf::is baseclass $e])
                } continue
                set c [$e info class]
                if {$omit_base_classes && [::nsf::is baseclass $c]} continue
                if {$c ni $things} {lappend iclasses $c}
                append instances "[dotquote $e]->[dotquote $c];\n"
            }
        }
        set superclasses ""
        set drawn ""
        foreach e $classes {
            if {![::nsf::is object $e]} continue
            set reduced_sc [list]
            foreach sc [::xo::getObjectProperty $e superclass] {
                if {$omit_base_classes && [::nsf::is baseclass $sc]} continue
                lappend reduced_sc $sc
            }
            if {$reduced_sc eq {}} {
                continue
            }
            foreach sc $reduced_sc {
                #
                # Draw always the superclass of the object of
                # interest, which might in the case of multiple
                # inheritance not in the "things" variable.  This
                # might leave out the superclass of the superclass.
                #
                if {$sc in $things || $sc ne "::nx::Object"} {
                    if {![dict exists $drawn $e-$sc]} {
                        append superclasses "[dotquote $e]->[dotquotel $sc];\n"
                        dict set drawn $e-$sc 1
                    }
                }
            }
        }
        set children ""
        set mixins ""
        foreach e $things {
            if {![::nsf::is object $e] || ($omit_base_classes && [::nsf::is baseclass $e])} 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}]  -hide_methods $hide_methods  -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

}"

XQL Not present:

Generic, PostgreSQL, Oracle