###########################################################################
# WebDot, the Server                                                      #
#                                                                         #
# John Ellson, ellson@graphviz.org                                        #
#                                                                         #
###########################################################################

###########################################################################
# configuration data
#
# At the top of this file should be some installation dependent code like:
#
#	#!/usr/bin/tclsh8.3
#	set LIBTCLDOT /usr/lib/graphviz/libtcldot.so
#	set CACHE_ROOT /var/cache/webdot
#	set GS /usr/bin/gs
#	set PS2EPSI /usr/bin/ps2epsi
#	set LOCALHOSTONLY 1
#
# This code is normally created during "make install"
#
# If fonts are not found automatically, you may also want to 
# add a line like:
#	set env(GDFONTPATH) /mnt/dos/c/windows/fonts/
#
# For a public webdot server, set LOCALHOSTONLY 0
#
###########################################################################

###########################################################################
# various data definitions - these should not require adjustment

# define the set of mime.types that we can convert graphs to
array set MIME {
    cmap    "text/plain"
    dot    "text/x-graphviz"
    epsi   "application/postscript"
    fig    "application/x-fig"
    gif    "image/gif"
    gv     "application/x-graphviz"
    hpgl   "application/x-hpgl"
    html   "text/html"
    imap    "text/plain"
    ismap    "text/plain"
    jpeg   "image/jpeg"
    map    "text/plain"
    mif    "application/x-mif"
    pcl    "application/x-pcl"
    pdf    "application/pdf"
    pic    "application/x-pic"
    png    "image/png"
    ps     "application/postscript"
    ps2     "application/postscript"
    src    "text/plain"
    svg    "image/svg+xml"
    svgz   "image/svg+xml"
    tcl    "application/x-tcl"
    tclmap "text/plain"
    txt    "text/plain"
    vrml   "x-world/x-vrml"
    vtx    "application/x-vtx"
}

# signature that is hyperlinked to help
set SIGNATURE "Graph by WebDot"

# timeout for network operations (webdot::get_url)
set TIMEOUT 5000

# latest mtime of LIBTCLDOT and this script
set t1 [file mtime $LIBTCLDOT]
set t2 [file mtime $argv0]
set SELFMTIME [expr $t1>$t2?$t1:$t2]

###########################################################################
#
# tclet preamble code that runs in the browser (no wish required on server)
#
# (This is a long section that is only applicable to clients
#  running the tclplugin.   If reading the server code please
# skip to the next ############ separator.)
#
set TCLET {
# Zoomable canvas tclet preamble by: John Ellson (ellson@graphviz.org)
# if running in a tclet...
# set tclet security policy to allow ::browser::displayURL
if {[catch {policy home}]} {
  set intclet 0
} {
  set intclet 1
}
# tclets probably don't have Tkspline available
set __tkgen_smooth_type true
# set default action  (Select, ZoomIn, ZoomOut)
set action Select
# initialize zoom values
set z_in_fact 1.11
set z_out_fact [expr 1.0 / $z_in_fact]
set z_depth 1.0
# create and pack the widgets
pack [frame .a] -side top -fill both -expand true
pack [frame .b] [frame .c] -side top -fill x
pack [scrollbar .a.v -command {.a.c yview}] -side right -fill y
set c [canvas .a.c -highlightthickness 0 -background lightblue \
  -xscrollcommand {.b.h set} -yscrollcommand {.a.v set}] 
pack $c -side left -fill both -expand true
pack [scrollbar .b.h -orient horiz -command {.a.c xview}] \
  -side left -fill x -expand true
pack [frame .b.pad -width [expr [.a.v cget -width] + \
    [.a.v cget -bd]*2 + [.a.v cget -highlightthickness]*2 ] \
  -height [expr [.b.h cget -width] + \
    [.b.h cget -bd]*2 + [.b.h cget -highlightthickness]*2 ]] -side right
pack [radiobutton .c.zoomout -text "ZoomOut " -value ZoomOut \
    -selectcolor yellow -variable action -indicatoron 0] \
  [radiobutton .c.zoomin -text "ZoomIn " -value ZoomIn \
    -selectcolor yellow -variable action -indicatoron 0] \
   [radiobutton .c.select -text Select  -value Select \
    -selectcolor yellow -variable action -indicatoron 0] -side right
pack [button .c.clear -text Clear -pady 0 -padx 0 \
  -command {.c.l configure -text {}}] -side left
pack [label .c.l -bg white -anchor w] -side left -fill x -expand true
# set up event bindings
bind $c <ButtonPress-1> {act $action %W %x %y}
bind $c <ButtonRelease-1> {endact $action %W}
bind $c <ButtonPress-2> {
  if {$action=="ZoomIn"} {set invaction ZoomOut} {set invaction ZoomIn}
  act $invaction %W %x %y
}
bind $c <ButtonRelease-2> {endact $invaction %W}
bind $c <ButtonPress-3> {rotateAction}
$c bind all <Enter> {balloon_up %W %x %y}
$c bind all <Leave> {balloon_down %W}
# binding support procs
proc balloon_up {c x y} {
  global currentItem saveFill balloon
    set currentItem [lindex [$c gettags current] 0] 
    if {$currentItem == "current"} {
    unset currentItem
    } {
    set currentItem [string range $currentItem 1 end]
      set saveFill [lindex [$c itemconfigure 1$currentItem -fill] 4]
      $c itemconfigure 1$currentItem -fill black -stipple gray25
      set balloon [after 100 "balloon_up2 $c $x $y"]
    }
}
proc balloon_up2 {c x y} {
  global currentItem labels
  foreach i [$c find withtag 0$currentItem] {
    if {[$c type $i] == "text"} {
      lappend label [lindex $labels($i) 0]
    }
  }
  if {[info exists label]} {
    set t [$c create text \
      [expr [$c canvasx $x] -5] [expr [$c canvasy $y] -5] \
      -anchor se -text [join $label \n] -tag _balloon]
    eval $c create rectangle [$c bbox $t] -fill white -tag _balloon
      $c raise $t
  }
}
proc balloon_down {c} {
  global currentItem saveFill balloon
  if {[info exists currentItem]} {
    $c itemconfigure 1$currentItem -fill $saveFill -stipple {}
    catch {after cancel $balloon}
    catch {$c delete _balloon}
    unset currentItem
  }
}
proc rotateAction {} {
  global action
  set actions {ZoomOut ZoomIn Select}
  set action [lindex $actions \
    [expr ([lsearch $actions $action] + 1) % [llength $actions]]]
}
proc act {action c x y} {
  global z_in_fact z_out_fact labels 
  switch $action {
    ZoomIn {
      balloon_down $c
      foreach i [array names labels] {
        $c itemconfigure $i -text {}
      }
      zoom $c [$c canvasx $x] [$c canvasy $y] $z_in_fact
    }
    ZoomOut {
      balloon_down $c
      foreach i [array names labels] {
        $c itemconfigure $i -text {}
      }
      zoom $c [$c canvasx $x] [$c canvasy $y] $z_out_fact
    }
    Select {
      select $c
    }
  }
}
proc endact {action c} {
  global repeat zoomaction z_depth labels
  catch {after cancel $repeat}
  foreach i [array names labels] {
    foreach {text fontname fontsize} $labels($i) {break}
    set fontsize [expr int($fontsize * $z_depth)]
    if {$fontsize} {
      $c itemconfigure $i -text $text -font [list $fontname $fontsize]
    }
  }
}
proc select {c} {
  global currentItem embed_args
  if {[info exists currentItem] && [info exists embed_args(src)]} {
    set t [.c.l cget -text]
    .c.l configure -text [lappend t $currentItem]
    set url [file tail $embed_args(src)]map?$currentItem
    browser::displayURL $url _current
  }
}
proc zoom {c x y fact} {
  global repeat z_depth
  $c scale all $x $y $fact $fact
  set z_depth [expr $z_depth * $fact]
  $c configure -scrollregion [$c bbox all]
  set repeat [after 100 "zoom $c $x $y $fact"]
}
# render data (if it was provided first in the form of array data)
if {[info exists classes]} {
  foreach {class shape props} $classes {
    foreach instance [array names $class] {
      foreach {aname zname} [split $instance .] {break}
      switch $class {
        nodes {
          eval $c move [eval $c create oval -2 -2 2 2 $props -tags 1$aname] $nodes($instance)
        }
        edges {
          eval $c create line $nodes($aname) $nodes($zname) $props -tags 1$instance
        }
        default {
          set coords [set [set class]($instance)]
          eval $c create $shape $coords $props -tags 1$aname
        }
      }
    }
  }
}
update
after idle {
  # when graph loading is complete...
  # scale graph to fit canvas
  foreach {llx lly urx ury} [$c bbox all] {break}
  if {[catch {
    set xscale [expr 1.0 * [winfo width $c] / ($urx - $llx)]
    set yscale [expr 1.0 * [winfo width $c] / ($urx - $llx)]
  }]} {
    set xscale 1.0
    set yscale 1.0
  }
  set scale [expr $xscale < $yscale ? $xscale : $yscale]
  if {$scale < 1.0} {
    $c scale all 0 0 $scale $scale
    set z_depth $scale
  }
  # find all text items and save text and font
  foreach i [$c find all] {
    if {[$c type $i] == "text"} {
      foreach {fontname fontsize} [$c itemcget $i -font] {break}
      set text [$c itemcget $i -text]
      set labels($i) [list $text $fontname $fontsize]
      # and adjust text size if we rescaled to fit canvas
      if {$z_depth != 1.0} {
        set fontsize [expr int($fontsize * $z_depth)]
        if {$fontsize} {
          $c itemconfigure $i -text $text -font [list $fontname $fontsize]
        } {
          $c itemconfigure $i -text {}
        }
      }
    }
  }
  $c configure -scrollregion [$c bbox all]
}
}
# end TCLET

###########################################################################
# proc definitions
###########################################################################

###########################################################################
# error 
#
# generate an error with an error message
#
proc toperror {m} {
	puts "Content-type: text/plain\n\nWebDot Error:\n\n$m"
	flush stdout
	puts {}
	exit
}

# propogate error to top
proc error {m} {
    return -code error $m
}

# webdot namespace

namespace eval webdot {
	namespace export \
		unencode \
		get_url \
		make_absolute_url \
		fix_graph_urls \
		read_graph \
		make_client_map \
		filter_html \
		get_image_size \
		make_product \
		send_help
}

###########################################################################
# webdot::unencode
#
# used to unescape query-strings in cgi scripts
#
#remove existing \ escapes
#translate + to space
#escape tcl sensitive characters
#replace all %nn sequences with formats
#evaluate all formats and lose the tcl escapes, result is return value

proc webdot::unencode {s} {
 regsub -all {\\(.)} $s {\1} s
 regsub -all {\+} $s { } s
 regsub -all {([\\\{$[])} $s {\\\1} s
 regsub -all {%([a-fA-F0-9][a-fA-F0-9])} $s {[format %c 0x\1]} s
 subst $s
}

###########################################################################
# webdot::get_url
#
# get file from a url, using previously cached copy if still good
#
# returns a list containing:
#        file_cache_dir      directory in cache for the src and products
#        LastModified        time string
#        Expires             time string
#        ContentType         mime string
#
proc webdot::get_url {url no_cache} {
    global CACHE_ROOT TIMEOUT LOCALHOSTONLY env

    # parse the url into component parts
    if {[scan $url {http://%[^/]%s} serverport path] != 2} {
        error "bad URL $url"
    }
    if {[scan $serverport {%[^:]:%s} server port] == 1} {set port 80}

    # now check for security
    if {$LOCALHOSTONLY
      && ! ([string equal $env(SERVER_ADDR) $server]
	  || [string equal $env(SERVER_NAME) $server]
          || [string equal localhost $server]
          || [string equal 127.0.0.1 $server])} {
            error "This webdot installation only delivers graphs from localhost"
    }

    # set default values
    foreach {ResponseCode Expires LastModified ContentType} {{} {} {} {}} {break}
    regsub -all {~} $path {%7E} path
    set file_cache_dir $CACHE_ROOT/$serverport$path
    if {[file isdirectory $file_cache_dir]} {
        if {! [catch {open $file_cache_dir/info r} f]} {
            foreach {LastModified Expires ContentType} [read $f] {break}
            close $f
        }
    } {
        if {[catch {file mkdir $file_cache_dir}]} {
            error "failure to create cache directory: $file_cache_dir"
        }
    }

    # see if we can use straight from cache
    if {![string length $Expires]
      || $no_cache
      || [catch {clock scan $Expires -gmt 1} t]
      || $t < [clock seconds]} {
        # no - so open connection to server
        if {[catch {socket $server $port} skt]} {
            error "failure to connect to $server:$port"
        }

        # send request
        regsub -all {%7E} $path {~} lpath
        puts $skt "GET $lpath HTTP/1.0"
        puts $skt "User-Agent: webdot"
        puts $skt "Host: $server"
        puts $skt "Accept: */*"
        if {$no_cache} {
            puts $skt "Pragma: no-cache"
        } {
            if {[string length $LastModified]} {
                puts $skt "If-Modified-Since: $LastModified"
            }
        }
        puts $skt {}
        flush $skt

        # get response
        set inbody 0
        while {$inbody < 2} {
            set selread {}
            after $TIMEOUT "error \"timeout on select read from $url\""
            fileevent $skt readable "set selread $skt"
            vwait selread
            after cancel "error \"timeout on select read from $url\""
            if {! $inbody} {
                # still processing header
                if {[catch {gets $skt} line]} {
		    close $skt
                    error "failure reading from: $url\nresponse was: $line"
                }
                regsub -all \r $line {} line
                switch [string tolower [lindex $line 0]] {
                    "http/1.0" - "http/1.1" {
                        scan $line {%*s %d %*s} ResponseCode
                        switch $ResponseCode {
                            200 {
                                if {[catch {open $file_cache_dir/src w} f_src]} {
        			    close $skt
                                    error "failure to open $file_cache_dir/src for write"
                                }
                            }
                            304 {set inbody 2}
                            404 {
        			close $skt
                                error "URL \"http://$server:$port$lpath\" was not found"
                            }
                            default {
        			close $skt
                                error "Response Code = $ResponseCode"
                            }
                        }
                    }
                    "last-modified:" {scan $line {%*s %[^~]} LastModified}
                    "expires:" {scan $line {%*s %[^~]} Expires}
                    "content-type:" {
			scan $line {%*s %[^~]} ContentType
			set ContentType [lindex [split $ContentType ;] 0]
		    }
                    {} {
                        incr inbody
                        if {[string equal $ResponseCode 200]} {
                            if {[catch {open $file_cache_dir/info w} f_info]} {
        			close $skt
                                error "failure to open $file_cache_dir/info for write"
                            }
                            puts -nonewline $f_info [list $LastModified $Expires $ContentType]
                            close $f_info
                        }
                    }
                }
            } {
                # in body - copy directly so no prob with binary data
                fconfigure $skt -translation binary
                fconfigure $f_src -translation binary
                fcopy $skt $f_src
                close $f_src
                incr inbody
            }
        }
        close $skt
    }

    return [list $file_cache_dir $LastModified $Expires $ContentType]
}

###########################################################################
# webdot::make_absolute_url
#
# support routine for webdot::fix_graph_urls
#
# returns: absolute_url
#
proc webdot::make_absolute_url {serverport dirname ref name} {
    regsub -all {\\N} $ref $name ref
    if {[scan $ref {http://%s} .] != 1} {
        if {[string first / $ref] == 0} {
            set ref http://$serverport$ref
        } {
            set ref http://$serverport$dirname/$ref
        }
    }
    return $ref
}

###########################################################################
# webdot::fix_graph_urls
#
# URL attributes of graph objects can be relative, and URLs of nodes
# can contain the escape sequence "\N" which will be replaced by the
# name of the node
#
# returns count of URLs found in graph (not BGURL)
#
proc webdot::fix_graph_urls {g serverport dirname} {
    set urls_found 0
    # expand relative URLs if we need them in the output format
    set name [$g showname]
    if {![catch {$g queryattr BGURL} bg_url]} {
        set bg_url [lindex $bg_url 0]
        if {[string length $bg_url]} {
            $g setattributes BGURL [webdot::make_absolute_url $serverport $dirname $bg_url $name]
        }
    }
    if {![catch {$g queryattr URL} g_url]} {
        set g_url [lindex $g_url 0]
        if {[string length $g_url]} {
            incr urls_found
            $g setattributes URL [webdot::make_absolute_url $serverport $dirname $g_url $name]
        }
    }
    foreach n [$g listnodes] {
        set name [$n showname]
        if {![catch {$n queryattr URL} n_url]} {
            set n_url [lindex $n_url 0]
            if {[string length $n_url]} {
                incr urls_found
                $n setattributes URL [webdot::make_absolute_url $serverport $dirname $n_url $name]
            }
        }
        foreach e [$n listoutedges] {
            set name [$e showname]
            if {![catch {$e queryattr URL} e_url]} {
                set e_url [lindex $e_url 0]
                if {[string length $e_url]} {
                    incr urls_found
                    $e setattributes URL [webdot::make_absolute_url $serverport $dirname $e_url $name]
                }
            }
        }
    }
    return $urls_found
}

###########################################################################
# webdot::read_graph
#
proc webdot::read_graph {} {
    global LIBTCLDOT

    # we're going to need the Tcldot extension to process the graph
    if {! [string length [info command dotread]]} {
        if {[catch {load $LIBTCLDOT} err]} {
            error $err
        }
    }
    # read in source file from cache
    if {[catch {open src r} f]} {
        error "Unable to open cache file for read: src"
    }
    fconfigure $f -encoding utf-8
    if {[catch {dotread $f} g]} {
        error "Invalid graph source: $g\nThere may be more details in the WebDot server's error_log,\nor check the graph file by running through dot (or neato or twopi) locally."
    }
    close $f
    return $g
}
        
###########################################################################
# webdot::make_client_map
#
proc webdot::make_client_map {url type engine no_cache count target} {
   global SELF

    # generate graph in requested format
    switch -- $type {
        png - gif - jpeg {
            # get source file into cache (may already be there)
	    if {[catch {webdot::get_url $url $no_cache} res]} {
		error $res
	    }
            foreach {file_cache_dir LastModified Expires ContentType} $res {break}
            # some types (e.g. vrml) result in mutiple files, so cd to target directory
            cd $file_cache_dir
	    if {[catch {webdot::make_product $url $type $engine $no_cache} err]} {
		error $err
	    }
            # generate map
            if {[catch {open $engine.cmap r} f]} {
                error "Unable to open cache file for read: $file_cache_dir/$engine.cmap"
            }
            puts "<map name=\"webdot$count\">"
            set default ""
            set havetarget [string length $target]
            foreach l [split [read $f] \n] {
                if {[scan $l {<!-- bb (%d,%d)} sizex sizey] == 2} {
                    # save bb for size
                } elseif {$havetarget && [regexp {<area (.*)>} $l . allbuttarget]} {
                    puts "<area $allbuttarget target=\"$target\">"
                } elseif {[string length $l]} {
                    puts $l
                }
            }
            close $f
            puts "</map>"
            puts "<img src=\"$SELF/$url.$engine.$type\"
	width=\"$sizex\" height=\"$sizey\" border=\"0\"
	usemap=\"#webdot$count\"
	alt=\"Graph by WebDot\">"
        }
	svg {
            # get source file into cache (may already be there)
	    if {[catch {webdot::get_url $url $no_cache} res]} {
		error $res
	    }
            foreach {file_cache_dir LastModified Expires ContentType} $res {break}
            # some types (e.g. vrml) result in mutiple files, so cd to target directory
            cd $file_cache_dir
            # generate svg
	    if {[catch {webdot::make_product $url $type $engine $no_cache} err]} {
		error $err
	    }
            if {[catch {open $engine.$type r} f]} {
                error "Unable to open cache file for read: $file_cache_dir/$engine.$type"
            }
            while {![eof $f]} {
                # remove leading comment when embedding svg in an html page
		if {[string equal [string range [gets $f] end-2 end] {-->}]} {break}
            }
            fcopy $f stdout
	    close $f
	}
        tcl {
            puts "<embed src=\"$SELF/$url.$engine.tcl\"
	width=\"600\" height=\"400\">
Graph in Tclet
</embed>"
        }
    }
}
###########################################################################
# webdot::filter_html 
#
#   processes <webdot> tags embedded in an html page
#
proc webdot::filter_html {serverport dirname no_cache} {
    global SELF STARTED_CONTENT_TYPE

    set f [open src r]
    set h [read $f]
    close $f

    puts "Content-Type: text/html\n"
    if {[catch {
        #iterate through "<webdot...>" tags in html document
        set count 0
        set start 0
        foreach {e_range se_range} \
          [regexp -all -nocase -indices -inline -- {\s*<webdot([^>]*)>\s*} $h] {
        
            #extract indices for the whole tag and for the subrange with the tag contents
            foreach {e_start e_end} $e_range {break}
            foreach {se_start se_end} $se_range {break}
    
            # output text before "<webdot"
            puts [string range $h $start [incr e_start -1]]
    
            # initialize args to default values
            foreach {src engine type alt target} {{} dot png {[graph]} {}} {break}
    
            # extract args
            foreach {. arg val} \
              [regexp -all -inline -- {(\w*)=([^\s]*)} [string range $h $se_start $se_end]] {

                # case ignore arg names
                set arg [string tolower $arg]
    
                # trim any quotes around val
                set val [string trim $val "\""]
    
                # check for legal args only
                switch -- $arg {
                    type - engine - src - alt - target {set $arg $val}
                }
            }

            set url [webdot::make_absolute_url $serverport $dirname $src {}]
    
            #case ignore type value
            set type [string tolower $type]
    
            webdot::make_client_map $url $type $engine $no_cache $count $target

            # mark start of text after current "<webdot...>" tag
            set start [incr e_end]
    
            # increment the counter that is used for "<map.." names in the generated html
            incr count
        }
    
        # output text after last "<webdot"
        puts -nonewline [string range $h $start end]

    } err ]} {
	puts "<pre><font color=red>$err</pre>"
    }
}

###########################################################################
# webdot::get_image_size
# 
# encapsulate this rather ugly calculation  (used in two places)
#
proc webdot::get_image_size {g} {
    if {![catch {$g queryattr orientation} or]
      && [string first land [string tolower $or]] == 0} {
        set landscape 1
    } {
        set landscape 0
    }
    if {[catch {$g queryattr size} sz]} {
    	scan [$g queryattr bb] "{%d %d %d %d}" lrx lry ulx uly
    	#  size of image is size of graph + (2 * margin)
    	set sizex [expr int(($ulx - $lrx + (2 * 10)) * 96./72)]
    	set sizey [expr int(($uly - $lry + (2 * 10)) * 96./72)]
    } {
	# this sucks!
	if {$landscape} {
		foreach {sizey sizex} [split $sz ,] {break}
	} {
		foreach {sizex sizey} [split $sz ,] {break}
	}
	set sizex [string trim $sizex {{} }]
	set sizey [string trim $sizey {{} }]
    	set sizex [expr int($sizex * 96)]
    	set sizey [expr int($sizey * 96)]
    }
    #  add a bit more for the signature
    incr sizex 5
    incr sizey 10
    # enforce a minimum width
    if {$sizex < 50} {set sizex 50}
    list $sizex $sizey
}

###########################################################################
# webdot::make_product
#
# convert "src" into "$type" in current directory
#
proc webdot::make_product {url type engine no_cache} {
    global env SIGNATURE GS PS2EPSI SELF TCLET SELFMTIME

    if {[scan $url {http://%[^/]%s} serverport path] != 2} {
        error "Invalid url: $url"
    }
    set dirname [file dirname $path]
    set cachename $engine.$type

    # see if we can use product from cache
    if {[file exists $cachename] && [file size $cachename] && ! $no_cache} {
        set t [file mtime $cachename]
	# must be later than the source, and later than the last modification
	# to this webdot script or libtcldot.so
        if {$t >= [file mtime src] && $t > $SELFMTIME} {
            return
        }
    }
    
    # no - so now we need to build it and save it in cache
    switch -- $type {
        png - jpeg - gif {
            # generates a map at the same time ready for inclusion
            # in an html page
            if {[catch {open $cachename w} f_out]} {
                error "Unable to open cache file for write: $cachename"
            }
            if {[catch {
                set g [webdot::read_graph]
		# set default background to transparent for web use
		if {[catch {$g queryattr bgcolor}]} {
		    $g setattributes bgcolor white
		}
                if {[catch {$g layout [string toupper $engine]} err]} {
                    error "Graph layout error: $err" 
                }
		foreach {sizex sizey} [webdot::get_image_size $g] {break}
                set gd [gd create $sizex $sizey]
    
                # Antialising against transparent background doesn't work well
                #  if actual background is not near white.  Need alpha channel.
                #set transparent [gd color new $gd 254 254 254]
                #gd color transparent $gd $transparent
                # Instead, set default background color to white
                gd color new $gd 255 255 255
        
                set hyperlink_blue [gd color new $gd 0 0 238]
                if {! [catch {$g queryattr BGURL} bgurl]} {
                    set bgurl [lindex $bgurl 0]
                    if {[string length $bgurl]} {
                        set bgurl [webdot::make_absolute_url $serverport $dirname $bgurl [$g showname]]
	                if {[catch {webdot::get_url $bgurl $no_cache} res]} {
                	    error $res
            		}
                        foreach {bg_file_cache_dir . . ContentType} $res {break}
                        if {[catch {open $bg_file_cache_dir/src r} bgf]} {
                            error "Unable to open background image file: $bg_file_cache_dir/src"
                        }
                        switch -- [string tolower $ContentType] {
                            image/png {
                                gd tile $gd [gd createFromPNG $bgf]
                            }
                            image/gif {
                                gd tile $gd [gd createFromGIF $bgf]
                            }
                            default {
                                error "unsupported mime type for background in=mage: $ContentType"
                            }
                        }
                        close $bgf
                        gd fill $gd tiled 0 0
                    }
                }
    
                # render graph
                $g rendergd $gd

                # Sign this piece of art (signature is hyperlinked to help)
                # first work out size of the signature in this font
                foreach {x0 y0 x1 y1 x2 y2 x3 y3} [gd text {} 0 \
                    times 8.0 0.0 0 0 $SIGNATURE] {break}
                # then place it accordingly in lower right corner
                gd text $gd $hyperlink_blue \
                    times 8.0 0.0 [expr $sizex - $x2 - 2] \
                    [expr $sizey - $y0 - 2] $SIGNATURE
    
                gd write[string toupper $type] $gd $f_out
                gd destroy $gd
                close $f_out

                # generate map
                if {[catch {open $engine.cmap w} f_out]} {
                    error "Unable to open cache file for write: $engine.cmap"
                }
                puts $f_out "<!-- bb ($sizex,$sizey) -->"
                puts $f_out "<area shape=\"rect\" href=\"$SELF/$url.$cachename.help\" title=\"$SIGNATURE\" alt=\"$SIGNATURE\" coords=\"[expr $sizex - $x2 - 4],[expr $sizey - ($x0 - $y2) - 4],$sizex,$sizey\">"
                flush $f_out
                $g write $f_out cmap
            	$g delete
            } err]} {
		# try to output an error message 
		if {! [string length [info command gd]]} {
		    # a bitmap is expected, but if that wom't work then a stderr message 
		    error $err
		}
		# write the error message to a bitmap
                set gd [gd create 500 100]
                set white [gd color new $gd 255 255 255]
                set red [gd color new $gd 255 0 0]
                set y 5
		foreach l [split $err \n] {
                    gd text $gd $red times 10.0 0.0 5 [incr y 20] $l
                }
                gd write[string toupper $type] $gd $f_out
                gd destroy $gd
                close $f_out

                # generate empty map with bb info of error message
                if {[catch {open $engine.cmap w} f_out]} {
                    error "Unable to open cache file for write: $engine.cmap"
                }
		puts $f_out "<!-- bb (500,100) -->"
	    }
       	    close $f_out
        }
        dot - gv {
            # for client side we use canonical dot format and don't bother with server side layout.
            set g [webdot::read_graph]
            webdot::fix_graph_urls $g $serverport $dirname
            if {[catch {open $cachename w} f_out]} {
                error "Unable to open cache file for write: $cachename"
            }
            $g write $f_out canon
            close $f_out
            $g delete
        }
        map {
            set g [webdot::read_graph]
            webdot::fix_graph_urls $g $serverport $dirname
            if {[catch {$g layout [string toupper $engine]} err]} {
                error "Graph layout error: $err" 
            }
            if {[catch {open $cachename w} f_out]} {
                error "Unable to open cache file for write: $cachename"
            }
            foreach {sizex sizey} [webdot::get_image_size $g] {break}
            puts $f_out "bb ($sizex,$sizey)"
            # work out size of the signature in this font
            foreach {x0 y0 x1 y1 x2 y2 x3 y3} [gd text {} 0 \
                times 8.0 0.0 0 0 $SIGNATURE] {break}
            puts $f_out "rectangle ([expr $sizex - $x2 - 4],$sizey) ($sizex,[expr $sizey - ($x0 - $y2) - 4]) $SELF/$url.$cachename.help $SIGNATURE"
            flush $f_out
            $g write $f_out ismap
            close $f_out
            $g delete
	}
        cmap {
            set g [webdot::read_graph]
            webdot::fix_graph_urls $g $serverport $dirname
            if {[catch {$g layout [string toupper $engine]} err]} {
                error "Graph layout error: $err" 
            }
            if {[catch {open $cachename w} f_out]} {
                error "Unable to open cache file for write: $cachename"
            }
            foreach {sizex sizey} [webdot::get_image_size $g] {break}
            puts $f_out "<!-- bb ($sizex,$sizey) -->"
            # work out size of the signature in this font
            foreach {x0 y0 x1 y1 x2 y2 x3 y3} [gd text {} 0 \
                times 8.0 0.0 0 0 $SIGNATURE] {break}
            puts $f_out "<area shape=\"rect\" href=\"$SELF/$url.$cachename.help\" title=\"$SIGNATURE\" alt=\"$SIGNATURE\" coords=\"[expr $sizex - $x2 - 4],[expr $sizey - ($x0 - $y2) - 4],$sizex,$sizey\">"
            flush $f_out
            $g write $f_out cmap
            close $f_out
            $g delete
        }
        tcl {
            set g [webdot::read_graph]
            if {[catch {$g layout [string toupper $engine]} err]} {
                error "Graph layout error: $err" 
            }
            if {[catch {open $cachename w} f_out]} {
                error "Unable to open cache file for write: $cachename"
            }
            # output the base tclet code
            #
            # tcl does strange things to backslashes even in {..} strings
            # this hack is needed to get the trailing backslash
	    puts $f_out "#!/bin/sh\n# the next line is a comment in tcl, but executable by sh \\"
            puts $f_out {exec wish "$0" ${1+"$@"}}
            puts $f_out "$TCLET"
            # output commands that render the graph on the canvas
            puts $f_out [$g render]
            close $f_out
            $g delete
        }
        tclmap {
            set g [webdot::read_graph]
            webdot::fix_graph_urls $g $serverport $dirname
            if {[catch {$g layout [string toupper $engine]} err]} {
                error "Graph layout error: $err" 
            }
            if {[catch {open $cachename w} f_out]} {
                error "Unable to open cache file for write: $cachename"
            }
            if {![catch {$g queryattr URL} url]} {
                set urls($g) $url
            }
            foreach n [$g listnodes] {
                if {![catch {$n queryattr URL} url]} {
                    set urls($n) $url
                }
                foreach e [$n listout] {
                    if {! [catch {$e queryattr URL} url]} {
                        set urls($e) $url
                    }
                }
            }
            if {[array exists urls]} {
                puts $f_out [array get urls]
            }
            close $f_out
            $g delete
        }
        pdf {
            if {[catch {webdot::make_product $url ps2 $engine $no_cache} err]} {
                error $err
            }
            exec $GS -q -dNOPAUSE -dBATCH -sPAPERSIZE=a0 -sDEVICE=pdfwrite -sOutputFile=$cachename $engine.ps2
        }
        epsi {
            if {[catch {webdot::make_product $url ps $engine $no_cache} err]} {
                error $err
            }
            exec $PS2EPSI $engine.ps $cachename
        }
        hpgl - fig - imap - mif - pcl - pic - ps - ps2 - svg - svgz - vtx - vrml {
            set g [webdot::read_graph]
            if {[catch {$g layout [string toupper $engine]} err]} {
                error "Graph layout error: $err" 
            }
            if {[catch {open $cachename w} f_out]} {
                error "Unable to open cache file for write: $cachename"
            }
            $g write $f_out $type
            close $f_out
            $g delete
        }
	src {}
        default {
            error "Don't know how to make target type: $type"
        }
    }
}

###########################################################################
# webdot::send_help
#
proc webdot::send_help {url type engine} {
    global SELF MIME

    puts "Content-Type: text/html\n
<html>
<head>
<title>WebDot Help Page</title>
<link rel=\"shortcut icon\" href=\"/webdot/icon.png\">
</head>
<body bgcolor=white>
<h1>WebDot Help Page</h1>"

    webdot::make_client_map $url $type $engine 0 0 new

    switch -- [string toupper $engine] {
        DOT {
	    set thisengine DOT
	    set otherengine1 NEATO
	    set otherengine2 TWOPI
	}
	NEATO {
	    set thisengine NEATO
	    set otherengine1 DOT
	    set otherengine2 TWOPI
	}
	TWOPI {
	    set thisengine TWOPI
	    set otherengine1 DOT
	    set otherengine2 NEATO
	}
    }

    puts "<p>This <a href=$url>graph</a> can be rendered by
WebDot using the $thisengine layout engine, in any of the following
formats:<pre>"

    set column 0
    foreach t {dot epsi fig gif gv hpgl jpeg mif pcl pdf pic png ps ps2 svg svgz tcl vrml vtx map ismap imap cmap src} {
	set mime "($MIME($t))"
	if {[string equal $t src]} {
	    set anchor "<a href=$SELF/$url.$t>$t $mime</a>"
	} {
	    set anchor "<a href=$SELF/$url.$engine.$t>$t $mime</a>"
	}
        puts -nonewline [format "%[expr 6-[string length $t]]s%s%[expr 25-[string length $mime]]s" {} $anchor {}]
        if {!([incr column]%3)} {puts ""}
    }
    puts "</pre>
<p>It can also be formatted by the 
<a href=$SELF/$url.[string tolower $otherengine1].$type.help>$otherengine1</a>
or the
<a href=$SELF/$url.[string tolower $otherengine2].$type.help>$otherengine2</a>
layout engines.
<p> Sources for WebDot can be found at:
<a href=http://www.graphviz.org/pub/graphviz/>http://www.graphviz.org/pub/graphviz/</a>
<p>
WebDot is by: <a href=mailto:ellson@graphviz.org>John Ellson (ellson@graphviz.org)</a>
</body></html>"
}

#############################################################
# If we are sourced from "Dtcl_Script ChildInitScript" then
# quit now.  The remaining function is provided by webdot.ttml/
if {[string length [info commands dtcl_info]]} {return}

###########################################################################
# main                                                                    #
###########################################################################

# init some variables
set STARTED_CONTENT_TYPE {}

# check cgi environment
foreach v {REMOTE_ADDR SERVER_NAME SERVER_PORT SCRIPT_NAME REQUEST_METHOD} {
        if {![info exists env($v)]} {toperror "Missing: $v"}
}
# some httpd don't provide SERVER_ADDR
if {![info exists env(SERVER_ADDR)]} {
	# stub in a safe address.  client won't be able to use IP
	# in URLs to dot files.
	set env(SERVER_ADDR) {127.0.0.1}
}
if {!([string equal $env(REQUEST_METHOD) GET]
    || [string equal $env(REQUEST_METHOD) HEAD])} {
        toperror "Missing or unsupported: REQUEST_METHOD"
}
set server_port ":$env(SERVER_PORT)"
if {[string equal $server_port :80]} {set server_port {}}

# see if we should use cache copy if it is available
set no_cache 0
if {[info exists env(HTTP_PRAGMA)]
  && [string equal $env(HTTP_PRAGMA) no-cache]} {
    set no_cache 1
}

# form absolute url from PATH_INFO
if {[info exists env(PATH_INFO)]} {
    # we allow encoding in PATH_INFO so that an encoded
    #  QUERY_STRING can be passed through to the graph server
    set path_info [webdot::unencode $env(PATH_INFO)]
    # second scan is an ugly hack for apache-2 servers that won't allow
    #  "//" in PATH_INFO strings.  They translate "//" to "/".
    if {[scan $path_info {/%[^:]://%[^/]%s} protocol serverport path] == 3
      || [scan $path_info {/%[^:]:/%[^/]%s} protocol serverport path] == 3} {
        if {![string equal $protocol http]} {
            toperror "Invalid URL. Only http protocol is allowed to upstream graph server."
        }
    } {
        set serverport $env(SERVER_NAME)$server_port
        set path $path_info
    }
    if {[scan $path {%[^\?]?%s} path through_query] != 2} {
	set havequery 0
    } {
	set havequery 1
    }
} {
    set serverport $env(SERVER_NAME)$server_port
    set path /
}

# analyze the (possibly multiple) extensions to path
#
# we want to deal with the following possible patterns of extensions:
#
#	filename.html			process <webdot>
#
#	filename.dot			(short for filename.dot.dot.dot)
#
#	filename.dot.png		(short for filename.dot.dot.png)
#	filename.dot.dot.png		convert to png using dot
#	filename.dot.neato.png		convert to png using neato
#	filename.dot.twopi.png		convert to png using twopi
#
#	filename.dot.png.help		(short for filename.dot.dot.png.help)
#	filename.dot.dot.png.help	put dot result in a help page
#	filename.dot.neato.png.help	put neato result in a help page
#	filename.dot.twopi.png.help	put twopi result in a help page
#
# "set help help" if .help is found at the end, otherwise "set help {}"
#
set parts [split [file tail $path] .]
if {[string equal [lindex $parts end] help]} {
	set help help
	set parts [lrange $parts 0 end-1]
} {
	set help {}
}

#
# if not enough parts, default to index.html
#
if {[llength $parts] < 2} {set parts {index html}}

# use first two parts as filename for cache
#   also, srctype may be used later if mimetype not understood
foreach {srcname srctype} $parts {break}
set dpath [file dirname $path]
if {[string equal $dpath /]} {
        set path /$srcname.$srctype
} {
        set path $dpath/$srcname.$srctype
}
set parts [lrange $parts 2 end]
#
# extract target type, and possibly a layout engine override
#
switch -- [llength $parts] {
	0 {set engine dot; set type dot}
	1 {set engine dot; set type $parts}
	default {foreach {engine type} $parts {break}}
}

# nasty hack to workaround bugs in Apache/2.0.36 and later
#if {[info exists env(SERVER_SOFTWARE)]
#    && [string equal $env(SERVER_SOFTWARE) "Apache/2.0.36 (Red Hat Linux)"]} {
	set env(SCRIPT_NAME) /cgi-bin/[file tail $argv0]
	if {[info exists env(PATH_INFO)]} {
		regsub -- {http:/([^/])} $env(PATH_INFO) {http://\1} env(PATH_INFO)
	}
#}

# form url for upstream get 
# and form SELF url to used in the href for help attached to the signature
if {$LOCALHOSTONLY} {
	set SELF $env(SCRIPT_NAME)
} {
	set SELF http://$env(SERVER_NAME)$server_port$env(SCRIPT_NAME)
}
# url is used in maps, so needs to keep public address of server
if {$havequery} {
	set url http://$serverport$path?$through_query
} {
	set url http://$serverport$path
}

# create a directory name for the cache
set dirname [file dirname $path]

# clean up type
switch -- $type {
    ismap {
        # type ismap is deprecated - retained for backward compatibility
        set type map
    }
    jpg {
        # use canonical type name
        set type jpeg
    }
    {} {
	# shouldn't happen, but just in case
        toperror "Missing type specification"
    }
}

# deal with help requests of the form:
#    http://a.b.c.d/cgi-bin/webdot/http://w.x.y.z/path/x.dot.png.help
#or:
#    http://a.b.c.d/cgi-bin/webdot/http://w.x.y.z/path/x.dot.dot.png.help
#or:
#    http://a.b.c.d/cgi-bin/webdot/http://w.x.y.z/path/x.dot.neato.png.help
#or:
#    http://a.b.c.d/cgi-bin/webdot/http://w.x.y.z/path/x.dot.twopi.png.help
# originated from the "Graph by WebDot" signatures.
if {[string length $help]} {
    webdot::send_help $url $type $engine
    exit
}

###########################################################################
# OK so maybe we have real work to do!

# get source file into cache (may already be there)
if {[catch {webdot::get_url $url $no_cache} res]} {
	toperror $res
}
foreach {file_cache_dir LastModified Expires ContentType} $res {break}

# some types (e.g. vrml) result in mutiple files, so cd to target directory
cd $file_cache_dir

# deal with html pages containing <webdot...> tags
if {[string equal $ContentType $MIME(html)]
       || [string equal $srctype html]} {
    webdot::filter_html $serverport $dirname $no_cache
    exit
}

if {! ([string equal $ContentType $MIME(dot)]
       || [string equal $ContentType $MIME(gv)]
       || [string equal $srctype gv]
       || [string equal $srctype dot])} {
    toperror "Unrecognized mimetype for graph: $ContentType\nand unrecognized file extension: $srctype"
}

# Support for client-side caching
#
# We could do this in webdot::get_url, but we must make sure src is in cache
# even if not-modified-since because the html processing will
# need it.  The output html may be modified by embedded webdot images even
# if the source html hasn't been changed.  To fix that would require
# buffering of the html while testing all of the embedded webdots, then
# only if no changes to the resulting html would not-modified
# be sent to the client. Basically this is all very messy for little benefit.
#
# Make sure an update is forced if Tcldot has changed
#
if {[info exists env(HTTP_IF_MODIFIED_SINCE)]} {
    if {[catch {clock scan $Expires -gmt 1} t]} {
       toperror "failed to parse time in env(HTTP_IF_MODIFIED_SINCE): $env(HTTP_IF_MODIFIED_SINCE)"
    }
    if {$t >= $LastModified && $t > $SELFMTIME} {
        puts "Status: 304 Not Modified\n"
        exit
    }
}

# convert the graph
if {[catch {webdot::make_product $url $type $engine $no_cache} err]} {
    toperror $err
}
# now the product is in the cache and we can ship it
if {[string equal $type src]} {
    set cachename src
} {
    set cachename $engine.$type
}
if {[catch {open $cachename r} f]} {
    toperror "Unable to open cache file for read: $file_cache_dir/$cachename"
}

# start preparing result http header
lappend header "Content-Type: $MIME($type)"
switch -- $type {
	svgz {
		lappend header "Content-Encoding: gzip"
	}
}
if {[string length $Expires]} {
    lappend header "Expires: $Expires"
}
if {[string length $LastModified]} {
    lappend header "Last-Modified: $LastModified"
}

# send output header
switch -- $type {
    gv - dot - png - gif - jpeg - mif - ps - ps2 - epsi - pdf - hpgl - pic - pcl - vrml - vtx - fig - svg - svgz - src - imap - cmap {
        puts [join $header \n]
    }
    tcl {
        lappend header "Pragma: no-cache"
        puts [join $header \n]
    }
    map {
        if {![info exists env(QUERY_STRING)]
          || ![string length $env(QUERY_STRING)]} {
            puts [join $header \n]
            set x {}
            set y {}
        } {
            foreach {x y} [split $env(QUERY_STRING) ,] {break}
        }
    }
    tclmap {
        if {![info exists env(QUERY_STRING)]
          || ![string length $env(QUERY_STRING)]} {
            puts [join $header \n]
            set query {}
        } {
            set query $env(QUERY_STRING)
        }
    }
    default {toperror "I don't know how to make type: $type"}
}

if {[string equal $type map] && [string length $x]} {
    # deal with server-side mapping (ismap)
    set defaulturl {}
    foreach l [split [read $f] \n] {
        if {[scan $l {rectangle (%d,%d) (%d,%d) %s %s} x1 y1 x2 y2 xy_url xy_label]} {
            if {(($x >= $x1 && $x <= $x2) || ($x <= $x1 && $x >= $x2))
		 && (($y >= $y1 && $y <= $y2) || ($y <= $y1 && $y >= $y2))} {
                puts "Location: $xy_url\n"
                set defaulturl {}
                break
            }
        } {
            scan $l {default %s} defaulturl
        }
    }
    if {[string length $defaulturl]} {
        puts "Location: $defaulturl\n"
    } {
	# no default - want this to do nothing
        puts "Status: 204 No URL for this location\n"
    }
} elseif {[string equal $type tclmap] && [string length $query]} {
    array set urls [read $f]
    if {[info exists urls($query)]} {
        puts "Location: $urls($query)\n"
    } {
	# no default - want this to do nothing
        puts "Status: 204 No URL for this location\n"
    }
} elseif {[string equal $type src]} {
    puts "Content-Length: [file size src]\n"
    if {![string equal $env(REQUEST_METHOD) HEAD]} {
        flush stdout
        fcopy $f stdout
        flush stdout
        puts {}
    }
} else {
    puts "Content-Length: [file size $engine.$type]\n"
    if {![string equal $env(REQUEST_METHOD) HEAD]} {
        flush stdout
        fconfigure $f -translation binary
        fconfigure stdout -translation binary
        fcopy $f stdout
        flush stdout
        puts {}
    }
}
close $f
