: #! /usr/bin/env tclsh
: 
: # Handle options
: ## Set defaults
: set options(DrawPorts) 1
: set options(DrawPortsSideways) 0
: set options(RankDir) RL
: set options(PostScript) 0
: set options(ClusterConnected) 1
: set options(RankSep) 2.0
: set options(DrawSameNodeEdges) 0
: 
: # Procedures
: proc __to_dot_node {str} {
: 	if {[regexp {^[0-9]} $str]} {
: 		set str "__$str"
: 	}
: 
: 	return [string map [list - _ / _ " " _ * _ . _] $str]
: }
: 
: proc __to_dot_port {str} {
: 	set work [split $str /]
: 	set subpart [lindex $work 1]
: 	if {[string index $subpart 0] == "g" && [llength $work] == 2} {
: 		set work [lreplace $work 1 1 [expr [string range $subpart 1 end] + 16384]]
: 		set str [join $work /]
: 	}
: 
: 	set str [string map [list - _ / _ " " _ . _] $str]
: 	return "port$str"
: }
: 
: proc __str_to_dot {str} {
: 	return [string map [list "&" "&" "-" "-"] $str]
: }
: 
: proc __ports_to_color {sport dport} {
: 	binary scan $sport H* snum
: 	binary scan $dport H* dnum
: 
: 	if {$::tcl_version == "8.4"} {
: 		set snum [string range $snum 0 6]
: 		set dnum [string range $dnum 0 6]
: 	}
: 	if {$snum == ""} {
: 		set snum "0"
: 	}
: 	if {$dnum == ""} {
: 		set dnum "0"
: 	}
: 	set snum "0x$snum"
: 	set dnum "0x$dnum"
: 	
: 	expr srand($snum + $dnum)
: 
: 	set edgecolor_part(r) [expr int(rand() * 192) + 32]
: 	set edgecolor_part(g) [expr int(rand() * 192) + 32]
: 	set edgecolor_part(b) [expr int(rand() * 192) + 32]
: 
: 	return [format "#%02x%02x%02x" $edgecolor_part(r) $edgecolor_part(g) $edgecolor_part(b)	]
: }
: 
: proc get_all_nodes_connected_to {node nodemapping {retval ""}} {
: 	array set node_mapping $nodemapping
: 
: 	lappend retval $node
: 
: 	if {[info exists node_mapping($node)]} {
: 		foreach target [lsort -dictionary $node_mapping($node)] {
: 			set dhost [lindex $target 1]
: 
: 			# Exclude hosts we have already visited
: 			if {[lsearch -exact $retval $dhost] != -1} {
: 				continue
: 			}
: 
: 			lappend retval $dhost
: 
: 			foreach childnode [get_all_nodes_connected_to $dhost $nodemapping $retval] {
: 				if {[lsearch -exact $retval $childnode] != -1} {
: 					continue
: 				}
: 
: 				lappend retval $childnode
: 			}
: 		}
: 
: 		unset node_mapping($node)
: 	}
: 
: 	foreach tmpnode [array names node_mapping] {
: 		foreach target [lsort -dictionary $node_mapping($tmpnode)] {
: 			set dhost [lindex $target 1]
: 
: 			if {$dhost == $node} {
: 				if {[lsearch -exact $retval $tmpnode] != -1} {
: 					continue
: 				}
: 
: 				lappend retval $tmpnode
: 
: 				foreach childnode [get_all_nodes_connected_to $tmpnode $nodemapping $retval] {
: 					if {[lsearch -exact $retval $childnode] != -1} {
: 						continue
: 					}
: 
: 					lappend retval $childnode
: 				}
: 			}
: 		}
: 
: 		unset node_mapping($tmpnode)
: 	}
: 
: 	return $retval
: }
: 
: ## Process user actions
: for {set idx 0} {$idx < [llength $argv]} {incr idx} {
: 	set arg [lindex $argv $idx]
: 
: 	if {[string index $arg 0] != "-"} {
: 		break
: 	}
: 
: 	switch -- $arg {
: 		"-p" - "--drawports" {
: 			set options(DrawPorts) 1
: 		}
: 		"-n" - "--nodrawports" {
: 			set options(DrawPorts) 0
: 		}
: 		"-r" - "--righttoleft" {
: 			set options(RankDir) RL
: 		}
: 		"-t" - "--toptobottom" {
: 			set options(RankDir) BT
: 		}
: 		"-R" {
: 			set options(RankDir) [string reverse $options(RankDir)]
: 		}
: 		"-w" - "--widenodes" {
: 			set options(DrawPortsSideways) 1
: 		}
: 		"-P" - "--postscript" {
: 			set options(PostScript) 1
: 		}
: 		"-u" - "--unclusterconnected" {
: 			set options(ClusterConnected) 0
: 		}
: 		default {
: 			if {$arg == "-h" || $arg == "--help"} {
: 				set outfd stdout
: 				set retval 0
: 			} else {
: 				puts stderr "Unknown argument: \"$arg\""
: 				set outfd stderr
: 				set retval 1
: 			}
: 
: 			puts $outfd "Usage: $argv0 \[-pnrtwPu\] \[--\[no\]drawports\] \[--righttoleft\] \[--toptobottom\] \[--widenodes\] \[--postscript\] \[--unclusterconnected\]"
: 
: 			exit $retval
: 		}
: 	}
: }
: set argv [lrange $argv $idx end]
: 
: # Set the title
: set options(Title) [lindex $argv 0]
: if {$options(Title) == ""} {
: 	set options(Title) "Unnamed Graph [clock format [clock seconds]] [info host]"
: }
: 
: # Hard-coded definitions
: set attr_info([list cluster *]) {cluster=$VALUE}
: 
: # Read edges from standard input
: set data [read stdin]
: foreach line [split $data \n] {
: 	# Check for pre-processor directives
: 	if {[regexp {^# *define  *} $line]} {
: 		set preproc [split [regsub {^# *define  *} $line {}]]
: 		set attr_name [lindex $preproc 0]
: 		set attr_val [lindex $preproc 1]
: 		set newattrs [join [lrange $preproc 2 end]]
: 
: 		lappend attr_info([list $attr_name $attr_val]) $newattrs
: 		continue
: 	}
: 
: 	if {[regexp {^# *setdot  *} $line]} {
: 		set preproc [split [regsub {^# *setdot  *} $line {}]]
: 		set set_node [lindex $preproc 0]
: 		set set_dot_attr [lindex $preproc 1]
: 		set set_dot_attrval  [join [lrange $preproc 2 end]]
: 		lappend user_attr($set_node) $set_dot_attr $set_dot_attrval
: 	}
: 
: 	
: 	if {[regexp {^# *set  *} $line]} {
: 		set preproc [split [regsub {^# *set  *} $line {}]]
: 		set set_node [lindex $preproc 0]
: 		set set_dot_attr [lindex $preproc 1]
: 		set set_dot_attrval  [join [lrange $preproc 2 end]]
: 
: 		set info [join [list "$set_node.$set_dot_attr" "$set_dot_attrval"] =]
: 		set line [join [list "" "" $info] "|"]
: 	}
: 
: 	if {[regexp {^# *option  *} $line]} {
: 		set preproc [split [regsub {^# *option  *} $line {}]]
: 		set set_option_name [lindex $preproc 0]
: 		set set_option_val [join [lrange $preproc 1 end]]
: 
: 		set options($set_option_name) $set_option_val
: 	}
: 
: 	# Remove comments and blank lines
: 	set line [regsub {#.*$} $line {}]
: 	set line [string trim $line]
: 	if {$line == ""} {
: 		continue
: 	}
: 
: 	# Tokenize into source, destination, and informational sections
: 	set work [split $line |]
: 
: 	if {[string match "*=*" [lindex $work end]]} {
: 		set info [string trim [lindex $work end]]
: 		set work [lrange $work 0 end-1]
: 	} else {
: 		set info ""
: 	}
: 
: 	set pathnodes [list]
: 	set pathedges [list]
: 	for {set dstidx 1} {$dstidx < [llength $work]} {incr dstidx} {
: 		set source [string trim [lindex $work [expr $dstidx - 1]]]
: 		set dest [string trim [lindex $work $dstidx]]
: 
: 		# Tokenize source and destination into node and port
: 		set source_work [split $source :]
: 		set dest_work [split $dest :]
: 
: 		set source_node [lindex $source_work 0]
: 		set source_port [lindex $source_work 1]
: 
: 		set dest_node [lindex $dest_work 0]
: 		set dest_port [lindex $dest_work 1]
: 
: 		# Skip entries with no source or destination node
: 		if {$source_node == "" || $dest_node == ""} {
: 			continue
: 		}
: 
: 		lappend node_mapping($source_node) [list $source_port $dest_node $dest_port]
: 
: 		lappend pathnodes $source_node
: 
: 		if {$source_port != ""} {
: 			lappend pathedges $source_node:$source_port
: 		}
: 	}
: 	if {[info exists dest_node]} {
: 		lappend pathnodes $dest_node
: 
: 		if {$dest_port != ""} {
: 			lappend pathedges $dest_node:$dest_port
: 		}
: 	}
: 
: 	# Process informational section
: 	foreach infoentry [split $info ,] {
: 		set infoentry [string map [list "\\=" "||||"] $infoentry]
: 		set infoentrywork [split $infoentry =]
: 		set infoentrywork [string map [list "||||" "="] $infoentrywork]
: 		set infoentry_targetattr [lindex $infoentrywork 0]
: 		set infoentry_attrval [lindex $infoentrywork 1]
: 
: 		set infoentry_targetattrwork [split $infoentry_targetattr .]
: 		set infoentry_target [lindex $infoentry_targetattrwork 0]
: 		set infoentry_attr [lindex $infoentry_targetattrwork 1]
: 
: 		foreach entrychk [array names attr_info] {
: 			set attr_name [lindex $entrychk 0]
: 			set attr_val [lindex $entrychk 1]
: 
: 			if {$infoentry_attr != $attr_name} {
: 				continue
: 			}
: 
: 			if {[string match $attr_val $infoentry_attrval]} {
: 				foreach dotattr $attr_info($entrychk) {
: 					set VALUE $infoentry_attrval
: 
: 					set dotattrwork [split $dotattr =]
: 					set dotattr_name [lindex $dotattrwork 0]
: 					set dotattr_val [subst [lindex $dotattrwork 1]]
: 
: 					set targets [list]
: 					switch -- $infoentry_target {
: 						"__PATHNODES__" {
: 							foreach pathnode $pathnodes {
: 								lappend targets $pathnode
: 							}
: 						}
: 						"__PATHEDGES__" {
: 							foreach pathedge $pathedges {
: 								lappend targets $pathedge
: 							}
: 						}
: 						default {
: 							lappend targets $infoentry_target
: 						}
: 					}
: 
: 					foreach target $targets {
: 						lappend user_attr($target) $dotattr_name $dotattr_val
: 					}
: 				}
: 			}
: 		}
: 	}
: }
: 
: # Emit DOT header.
: puts "digraph \"$options(Title)\" {"
: puts "  label = \"$options(Title)\";"
: puts {  normalize = true;}
: puts "  rankdir = $options(RankDir);"
: puts "  ranksep = $options(RankSep);"
: puts {  overlap = false;}
: puts {  remincross = true;}
: puts {  pack = true;}
: puts {  compound = true;}
: puts {  center = true;}
: if {$options(PostScript)} {
: 	puts {  page = "8.5, 11.0";}
: }
: puts {  outputorder = "nodesfirst";}
: puts {  node [shape=box,fontname="Helvetica",style="rounded,filled"];}
: puts {  edge [arrowhead=normal,arrowtail=normal,decorate=true];}
: if {[info exists options(Splines)]} {
: 	puts "  splines = \"$options(Splines)\";"
: }
: 
: # Get list of all nodes
: set allnodes [list]
: foreach node [array names node_mapping] {
: 	foreach target $node_mapping($node) {
: 		set dhost [lindex $target 1]
: 
: 		if {[lsearch -exact $allnodes $dhost] == -1} {
: 			lappend allnodes $dhost
: 		}
: 	}
: 
: 	if {[lsearch -exact $allnodes $node] == -1} {
: 		lappend allnodes $node
: 	}
: }
: 
: # Apply wildcard attributes to all nodes
: foreach node $allnodes {
: 	foreach attr_name [array names user_attr] {
: 		if {[string match "$attr_name" $node] && $attr_name != $node} {
: 			foreach attr_val $user_attr($attr_name) {
: 				set NODENAME $node
: 				lappend user_attr($node) [subst $attr_val]
: 			}
: 		}
: 	}
: }
: 
: # Set group on all node from "cluster" Dot attribute
: set node_clusters [list]
: foreach node $allnodes {
: 	unset -nocomplain node_attrs
: 	if {[info exists user_attr($node)]} {
: 		array set node_attrs $user_attr($node)
: 	}
: 
: 	if {[info exists node_attrs(cluster)]} {
: 		set cluster $node_attrs(cluster)
: 
: 		if {$options(ClusterConnected)} {
: 			set connnodes [get_all_nodes_connected_to $node [array get node_mapping]]
: 		} else {
: 			set connnodes [list $node]
: 		}
: 
: 		foreach connnode $connnodes {
: 			unset -nocomplain tmp_node_attrs
: 
: 			array set tmp_node_attrs [list]
: 			if {[info exists user_attr($connnode)]} {
: 				array set tmp_node_attrs $user_attr($connnode)
: 			}
: 
: 			unset -nocomplain tmp_node_attrs(cluster)
: 			set tmp_node_attrs(group) [__to_dot_node cluster_$cluster]
: 			if {[lsearch -exact $node_clusters $cluster] == -1} {
: 				lappend node_clusters $cluster
: 			}
: 
: 			set user_attr($connnode) [array get tmp_node_attrs]
: 		}
: 	}
: }
: unset -nocomplain node_attrs tmp_node_attrs connnode node cluster
: lappend node_clusters __DEFAULT__
: 
: # Draw all nodes
: foreach node [array names node_mapping] {
: 	foreach target $node_mapping($node) {
: 		set sport [lindex $target 0]
: 		set dhost [lindex $target 1]
: 		set dport [lindex $target 2]
: 
: 		if {$sport != ""} {
: 			lappend node_ports($node) $sport
: 		}
: 		if {$dport != "" && $dhost != ""} {
: 			lappend node_ports($dhost) $dport
: 		}
: 
: 	}
: }
: 
: foreach cluster $node_clusters {
: 	if {$cluster != "__DEFAULT__"} {
: 		puts "  subgraph \"[__to_dot_node cluster_$cluster]\" \{"
: 		puts "    label = \"$cluster\";"
: 		set indent "    "
: 	} else {
: 		set indent "  "
: 	}
: 
: 	foreach node $allnodes {
: 		unset -nocomplain node_attrs
: 		if {[info exists user_attr($node)]} {
: 			array set node_attrs $user_attr($node)
: 		}
: 
: 		if {$cluster == "__DEFAULT__"} {
: 			if {[info exists node_attrs(group)]} {
: 				continue
: 			}
: 		} else {
: 			if {![info exists node_attrs(group)]} {
: 				continue
: 			}
: 
: 			if {$node_attrs(group) != [__to_dot_node cluster_${cluster}]} {
: 				continue
: 			}
: 		}
: 
: 		set node_dot_attrs_list [list]
: 		set node_label {<TABLE BORDER="0" CELLBORDER="1" CELLSPACING="1">}
: 		append node_label "<TR><TD TITLE=\"[__str_to_dot $node]\" BORDER=\"0\">$node</TD></TR>"
: 		if {[info exists node_ports($node)]} {
: 
: 			if {$options(DrawPorts)} {
: 				if {$options(DrawPortsSideways)} {
: 					append node_label "<TR>"
: 					set portheader ""
: 					set porttrailer ""
: 				} else {
: 					set portheader "<TR>"
: 					set porttrailer "</TR>"
: 				}
: 
: 				set foundPorts [list]
: 				foreach port [lsort -dictionary $node_ports($node)] {
: 					if {[lsearch -exact $foundPorts $port] != -1} {
: 						continue
: 					}
: 
: 					lappend foundPorts $port
: 
: 					append node_label "${portheader}<TD PORT=\"[__to_dot_port $port]\" TITLE=\"[__str_to_dot $node:$port]\">$port</TD>${porttrailer}"
: 				}
: 
: 				if {$options(DrawPortsSideways)} {
: 					append node_label "</TR>"
: 				}
: 
: 			}
: 
: 		}
: 		append node_label {</TABLE>}
: 
: 		set node_attrs(label) "<$node_label>"
: 
: 		foreach attrlookupnode [list $node __NODE__] {
: 			if {[info exists user_attr($attrlookupnode)]} {
: 				foreach {attr_name attr_val} $user_attr($attrlookupnode) {
: 					set node_attrs($attr_name) $attr_val
: 				}
: 			}
: 		}
: 
: 		foreach {node_dot_attr_name node_dot_attr_val} [array get node_attrs] {
: 			if {$node_dot_attr_name == "cluster"} {
: 				continue
: 			}
: 
: 			lappend node_dot_attrs_list "$node_dot_attr_name=$node_dot_attr_val"
: 		}
: 
: 		puts "${indent}[__to_dot_node $node] \[[join $node_dot_attrs_list ,]\];"
: 	}
: 
: 	if {$cluster != "__DEFAULT__"} {
: 		puts "  \}"
: 	}
: }
: 
: # Draw all edges
: if {$options(DrawPortsSideways)} {
: 	set compasssrc _
: 	set compassdst _
: } else {
: 	set compasssrc _
: 	set compassdst _
: }
: 
: foreach node [array names node_mapping] {
: 	# Create edges from node
: 	foreach target [lsort -dictionary $node_mapping($node)] {
: 		set sport [lindex $target 0]
: 		set dhost [lindex $target 1]
: 		set dport [lindex $target 2]
: 
: 		if {!$options(DrawSameNodeEdges)} {
: 			if {$node == $dhost} {
: 				continue
: 			}
: 		}
: 
: 		unset -nocomplain edge_attrs
: 		set edge_attrs(splines) "false"
: 		set edge_attrs(color) [__ports_to_color $sport $dport]
: 
: 		foreach attrlookupedge [list __EDGE__ $node-$dhost $node:$sport $dhost:$dport] {
: 			if {[info exists user_attr($attrlookupedge)]} {
: 				foreach {attr_name attr_val} $user_attr($attrlookupedge) {
: 					set edge_attrs($attr_name) $attr_val
: 				}
: 			}
: 		}
: 
: 		set edge_attrs_list [list]
: 		foreach attr [array names edge_attrs] {
: 			lappend edge_attrs_list "$attr=\"[string trim $edge_attrs($attr) "\" "]\""
: 		}
: 
: 		set edge_attrs_str [join $edge_attrs_list ,]
: 
: 		puts "  [__to_dot_node $node]:[__to_dot_port $sport]:${compasssrc} -> [__to_dot_node $dhost]:[__to_dot_port $dport]:${compassdst} \[$edge_attrs_str\];"
: 	}
: }
: 
: 
: # Emit footer
: puts "}"