# output.tcl
# This code is responsible for generating HTML from the contents
# of the text widget.   The main idea is that text marks are
# used as placeholders for the HTML tags.

# Emit HTML based on the contents of the text widget

proc Output_Reset {win} {
    # Clear out window-specific output routines.
    foreach command [info commands Output$win*] {
	rename $command {}
    }
}
proc Output {win file {bodyOnly 0}} {
    global OutputNewline
    set OutputNewline 0
    if [catch {open $file w} out] {
	Status $win $out
	return 0
    }
    if {!$bodyOnly} { puts $out [Head_Output $win] }
    OutputInner $win 1.0 end \
	[list OutputText $out] \
	[list OutputTag $out]
    if {!$bodyOnly} { puts $out [Head_OutputTail $win] }
    close $out
    return 1
}

# The following table is used to get moderatly pretty raw HTML output
# One problem is that output may pick up the decorative newlines, too.
array set Output_format {
    title \n<%s>
    /title  <%s>\n
    p	\n<%s>\n
    h1	\n\n<%s>
    h2	\n\n<%s>
    h3	\n\n<%s>
    h4	\n<%s>
    h5	\n<%s>
    h6	\n<%s>
    /h1	<%s>\n
    /h2	<%s>\n
    /h3	<%s>\n
    /h4 <%s>\n
    /h5	<%s>\n
    /h6	<%s>\n
    blockquote	\n<%s>
    ol	\n<%s>
    /ol	\n<%s>\n
    ul	\n<%s>
    /ul	\n<%s>\n
    dl  \n<%s>
    /dl	\n<%s>\n
    dir		\n<%s>
    /dir	\n<%s>\n
    menu	\n<%s>
    /menu	\n<%s>\n
    li	\n<%s>
    dd	\n<%s>
    dt	\n<%s>
    br	\n<%s>\n
    hr	\n<%s>
    pre \n<%s>
    /pre <%s>\n
    tr	\n<%s>
    td	\n<%s>
    th	\n<%s>
    option \n<%s>
    /select \n<%s>
}

# OutputTag uses the formatting table above to generate readable output

proc OutputTag {out stateVar htag} {
    global Output_format
    upvar $stateVar state
    set key [lindex $htag 0]
    if {!$state(pre) && [info exists Output_format($key)]} {
	set format $Output_format($key)
	if $state(newline) {
	    set format [string trimleft $format \n]
	}
	set string [format $format $htag]
	puts -nonewline $out $string
	set state(newline) [regexp "\n$" $format]
	if !$state(newline) {
	    set len [string length $string]
	    if [regexp ^\n $format] {
		set state(linelength) [incr len -1]
	    } else {
		incr state(linelength) $len
	    }
	} else {
	    set state(linelength) 0
	}
    } else {
	puts -nonewline $out <$htag>
	set state(newline) 0
	incr state(linelength) [string length <$htag>]
    }
}
proc OutputText {out stateVar text} {
    upvar $stateVar state
    if {[string length $text] == 0} {
	return
    }
    set text [HMmap_code $text]
    if $state(pre) {
	set state(newline) [regexp "\n$" $text]
	puts -nonewline $out $text
    } else {
	set LIMIT 65
	set extra [expr [string length $text] + $state(linelength) - $LIMIT]
	while {$extra > 0} {
	    set ok [expr $LIMIT - $state(linelength)]
	    if {$ok >= 0} {
		puts -nonewline $out [string range $text 0 $ok] ; flush $out
		incr state(linelength) $ok
		incr ok
		set text [string range $text $ok end]
	    }
	    set ix [string first { } $text]
	    if {$ix < 0} {
		break
	    }
	    incr ix -1
	    puts $out [string range $text 0 $ix] ; flush $out
	    incr ix 2
	    set text [string range $text $ix end]
	    set state(linelength) 0
	    set state(newline) 1
	    set extra [expr [string length $text] - $LIMIT]
	}
	set len [string length $text]
	if {$len > 0} {
	    set state(newline) 0
	    incr state(linelength) $len
	    puts -nonewline $out $text ; flush $out
	}
    }
}

# Return HTML that describes the selection

proc Output_selection {win offset maxbytes } {
    upvar #0 HM$win var
    set var(result) {}
    OutputInner $win sel.first sel.last \
	[list _OutputSelectText $win] \
	[list _OutputSelectTag $win 1]
    return [string range $var(result) $offset [expr $offset+$maxbytes]]
}
# Append to result in the scope of Output_selection
proc _OutputSelectText {win stateVar text} {
    upvar #0 HM$win var
    append var(result) [HMmap_code $text]
}
proc _OutputSelectTag {win resolve stateVar htag} {
    upvar #0 HM$win var
    upvar $stateVar state
    if {$resolve && !$state(base)} {

	# If there is a relative reference (SRC= or HREF=) then emit a
	# <base> tag so the pasting application can resolve it, if needed.

	if {([regexp -nocase ^img $htag] && [HMextract_param $htag src link]) ||
	     ([regexp -nocase "^a\[ \t]+href" $htag] && 
		 [HMextract_param $htag href link])} {
	    if ![regexp {^([^ :]+):/} $link] {
		append var(result) "<base href=$var(S_url)>"
		set state(base) 1
	    }
	}
    }
    append var(result) <$htag>
}

# Get a range of text as HTML
proc Output_string {win m1 m2} {
    upvar #0 HM$win var
    set var(result) {}
    OutputInner $win $m1 $m2 \
	[list _OutputSelectText $win] \
	[list _OutputSelectTag $win 0]
    return $var(result)
}

# Output HTML as plain text
proc Output_text {win m1 m2 file} {
    if [catch {open $file w} out] {
	Status $win "$file: $out"
	return
    }
    OutputInner $win $m1 $m2 \
	[list OutputTextPlain $out] \
	[list OutputTagPlain $out]
    close $out
}
proc OutputTextPlain {out stateVar text} {
    upvar $stateVar state
    if {[string length $text] == 0} {
	return
    }
    puts -nonewline $out $text
}
proc OutputTagPlain {out stateVar htag} {
    global Output_format
    upvar $stateVar state
    if $state(pre) {
	return
    }
    set key [lindex $htag 0]
    if [info exists Output_format($key)] {
	regsub -all <%s> $Output_format($key) {} format
	puts -nonewline $out [format $format]
    } else {
	puts -nonewline $out { }
    }
}


# The main output loop.
# OutputInner uses the text dump command to iterate over the text.

proc OutputInner {win start end textProc tagProc} {
    global StyleMap
    # Don't pollute the output
    Mark_HideHtml $win

    # Do this so that the dump operation gets all (or none) of the marks
    # and tag transitions at the beginning (or end) of the range
    set start [$win index $start]
    set end [$win index $end]

    set state(textProc) $textProc
    set state(tagProc) $tagProc
    set state(space) 0		;# True within list decorations
    set state(pre) 0		;# True withing <pre> blocks
    set state(base) 0		;# True if emitted a <base> tag
    set state(newline) 0	;# True after emitting a newline
    set state(linelength) 0	;# Length of output line

    # Find active Style tags
    set tags {}
    foreach tag [$win tag names $start] {
	if {[regexp {H:([^ 	]+)} $tag x htag] &&
		[info exists StyleMap($htag)]} {
	    lappend tags $tag
	}
    }
    # Now subtract out any that start at the begining of the range
    # so they are not counted twice
    foreach {key val ix} [$win dump -tag $start] {
	if {$key == "tagon"} {
	    set ix [lsearch $tags $val]
	    if {$ix >= 0} {
		set tags [lreplace $tags $ix $ix]
	    }
	}
    }
    # Emit style tags that are already active at the beginning of the range
    foreach tag $tags {
	OutputIt state $win tagon $tag [$win index $start]
    }
    # Emit text and tags within the range
    $win dump -mark -tag -text -window -command [list OutputIt state $win] \
	    $start $end

    # Emit tag transitions at the end of the range
    # Ignore <img> and <li> tags at the end of the range
    $win dump -tag -command [list OutputIt state $win] $end
    OutputTagProc state $win
}

# OutputIt is called back on each text element: mark, tag toggle, or text
# There are a few important points:
# 1. marks and tags at the same index are collected
#    together in order to do a semantic sort on their order.
# 2. The decorative list decorations are skipped over.
# 3. <pre> blocks are detected to avoid inserting extra newlines.

proc OutputIt {stateVar win key value ix} {
    upvar $stateVar state

    set code [catch {

    switch -- $key {
	text {
	    # Handle any tags we've buffered up at this index
	    OutputTagProc state $win
	    if [info exists state(displayproc)] {
		# Just displaying the tags in the window
		return
	    }
	    if {! $state(space)} {
		eval $state(textProc) state {$value}
	    }
	    return
	}
	window {
	    # Similar to text.  Output any buffered tags so that sequences
	    # like <a ...><img></a> work right.  It is crucial that the
	    # <img> and </a> not appear at the same location or they get
	    # switched by the output sort routine.  It appears that the
	    # window segment comes after the mark that defines the <img> tag
	    OutputTagProc state $win
	    # Do object-specific output for tables, selection boxes, etc.
	    if {[info command Output$value] != {}} {
		Output$value state $win $value
	    }
	    return
	}
	mark {
	    if [regexp {^M:} $value] {
		set htag [Mark_Htag $win $value]
	    } else {
		return
	    }
	}
	tagon {
	    if [regexp ^(space|mark)$ $value] {
		set state(space) 1
		return
	    }
	    if ![regexp {^H:(.+)$} $value x htag] {
		return
	    }
	}
	tagoff {
	    if [regexp ^(space|mark)$ $value] {
		set state(space) 0
		return
	    }
	    if ![regexp {^H:(.+)$} $value x htag] {
		return
	    }
	    set htag /[lindex $htag 0]
	}
    }
    # Remember all the tags and output them just before the next text
    lappend state(savedTags) [list $ix $htag]

    } err] 

    if {$code != 0 && $code != 2} {
	Stderr "OutputIt: $err"
    }
}

# This is a text dump callback that is just used at the end of a range.
# It is only interested in tagoff toggles.

proc OutputCloseTags {stateVar win key value ix} {
    upvar $stateVar state
    if {$key == "tagoff"} {
	if ![regexp {^H:(.+)$} $value x htag] {
	    return
	}
	set htag /[lindex $htag 0]
	lappend state(savedTags) [list $ix $htag]
    }
}

# OutputTagProc is called after a set of tag toggles and marks that
# represent HTML at the same index have been collected.
# It sorts them and then makes
# the client-specific callback to process the HTML tag.

proc OutputTagProc {stateVar win} {
    upvar $stateVar state

    if ![info exist state(savedTags)] return

    if {[llength $state(savedTags)] > 1} {
	set tags [lsort -command [list OutputSortMarks $win] $state(savedTags)]
    } else {
	set tags $state(savedTags)
    }
    foreach x $tags {
	lassign {ix htag} $x
	regsub {^(/?)(ol|ul|dl|menu|dir)=[0-9]+} $htag {\1\2} htag
	OutputOneTag $stateVar $win $htag $ix
    }
    unset state(savedTags)
}
proc OutputOneTag {stateVar win htag ix} {
    upvar $stateVar state
    if [info exists state(displayproc)] {
	eval $state(displayproc) {$ix $htag}
    } else {
	eval $state(tagProc) state {$htag}
	if [string match textarea* $htag] {
	    # XXX still probably broken
#	    eval $state(textProc) {[Mark_FormTextValue $win $ix]}
	}
	if [string match pre $htag] {
	    set state(pre) 1
	}
	if [string match /pre $htag] {
	    set state(pre) 0
	}
    }
}

# Sort tags at the same spot.
# Return 1 if h1 > h2, else -1
# SortMap is set up so that:
# lists > nodes > singletons > styles
# open lists sort before open nodes
# open nodes sort before singletons
# singletons sort before open styles
# and the reverse is true for close tags.
# tags of the same order are sorted alphabetically
#
proc OutputSortMarks {win a b} {
    return [OutputSortHtags [lindex $a 1] [lindex $b 1]]
}
proc OutputSortHtags {h1 h2} {
    global SortMap SortList SortListEnd SortUnknown
    if {[string compare $h1 $h2] == 0} {
	return 0
    }

    # Pick out the slash, and the level from tags like "ol=1"

    regexp {(/)?([^ 	=]+)(=([0-9]+))?} $h1 x end1 t1 y level1
    regexp {(/)?([^ 	=]+)(=([0-9]+))?} $h2 x end2 t2 y level2

    set order1 [expr {[info exists SortMap($end1$t1)] ? $SortMap($end1$t1) : $SortUnknown}]
    set order2 [expr {[info exists SortMap($end2$t2)] ? $SortMap($end2$t2) : $SortUnknown}]

    if {$order1 == $order2} {
	if {$order1 == $SortList || $order1 == $SortListEnd} {
	    # Lists, assert levels are not equal
	    if {$level1 == $level2} {
		# This only happens if there are bugs elsewhere
		set s 0
	    } else {
		set s [expr {($level1 < $level2) ? -1 : 1}]
		set s [expr {"$end1" == "/" ? -$s : $s}]
	    }
	} else {
	    set s [string compare $t1 $t2]
	    set s [expr {"$end1" == "/" ? -$s : $s}]
	}
    } elseif {$order1 < $order2} {
	set s -1
    } else {
	set s 1
    }
    return $s
}
