# supertext.tcl v1.01
#
# Copyright (c) 1998 Bryan Oakley
# All Rights Reserved
#
# this code is freely distributable, but is provided as-is with
# no waranty expressed or implied.

# send comments to oakley@channelpoint.com

# What is this?
# 
# This is a replacement for (or superset of , or subclass of, ...) 
# the tk text widget. Its big feature is that it supports unlimited
# undo. It also has two poorly documented options: -preproc and 
# -postproc. 

# The entry point to this widget is supertext::text; it takes all of
# the same arguments as the standard text widget and exhibits all of
# the same behaviors.  The proc supertext::overrideTextCommand may be
# called to have the supertext widget be used whenever the command
# "text" is used (ie: it imports supertext::text as the command "text"). 
# Use at your own risk...

# To access the undo feature, use ".widget undo". It will undo the
# most recent insertion or deletion. On windows and the mac
# this command is bound to <Control-z>; on unix it is bound to
# <Control-_>

# if you are lucky, you might find documentation here:
# http://www1.clearlight.com/~oakley/tcl/supertext.html

package provide supertext 1.01

namespace eval supertext {

    variable undo
    variable undoIndex
    variable text "::text"
    variable preProc
    variable postProc

    namespace export text
}

# this proc is probably attempting to be more clever than it should...
# When called, it will (*gasp*) rename the tk command "text" to "_text_", 
# then import our text command into the global scope. 
#
# Use at your own risk!

proc supertext::overrideTextCommand {} {
    variable text

    set text "::_text_"
    rename ::text $text
    uplevel #0 namespace import supertext::text
}

proc supertext::text {w args} {
    variable text
    variable undo
    variable undoIndex
    variable preProc
    variable postProc

    # this is what we will rename our widget proc to...
    set original __$w

    # do we have any of our custom options? If so, process them and 
    # strip them out before sending them to the real text command
    if {[set i [lsearch -exact $args "-preproc"]] >= 0} {
	set j [expr $i + 1]
	set preProc($original) [lindex $args $j]
	set args [lreplace $args $i $j]
    } else {
	set preProc($original) {}
    }

    if {[set i [lsearch -exact $args "-postproc"]] >= 0} {
	set j [expr $i + 1]
	set postProc($original) [lindex $args $j]
	set args [lreplace $args $i $j]
    } else {
	set postProc($original) {}
    }

    # let the text command create the widget...
    eval $text $w $args

    # now, rename the resultant widget proc so we can create our own
    rename ::$w $original

    # here's where we create our own widget proc.
    proc ::$w {command args} \
        "namespace eval supertext widgetproc $w $original \$command \$args"
    
    # set up platform-specific binding for undo; the only one I'm
    # really sure about is winders; the rest will stay the same for
    # now until someone has a better suggestion...
    switch $::tcl_platform(platform) {
	unix 		{
		event add <<Undo>> <Control-z>
		event add <<Undo>> <Control-Z>
	}
	windows 	{
		event add <<Undo>> <Control-z>
		event add <<Undo>> <Control-Z>
	}
	macintosh 	{
		event add <<Undo>> <Control-z>
		event add <<Undo>> <Control-Z>
	}
    }
    bind $w <<Undo>> "$w undo"

    set undo($original)	{}
    set undoIndex($original) -1
    set clones($original) {}

    return $w
}

# this is the command that we associate with a supertext widget. 
proc supertext::widgetproc {this w command args} {

    variable undo
    variable undoIndex
    variable preProc
    variable postProc

    # these will be the arguments to the pre and post procs
    set originalCommand $command
    set originalArgs $args

    # is there a pre-proc? If so, run it. If there is a problem,
    # die. This is potentially bad, because once there is a problem
    # in a preproc the user must fix the preproc -- there is no
    # way to unconfigure the preproc. Oh well. The other choice
    # is to ignore errors, but then how will the caller know if
    # the proc fails?
    if {[info exists preProc($w)] && $preProc($w) != ""} {
	if {[catch "$preProc($w) command args" error]} {
	    return -code error "error during processing of -preproc: $error"
	}
    }


    # if the command is "undo", we need to morph it into the appropriate
    # command for undoing the last item on the stack
    if {$command == "undo"} {

	if {$undoIndex($w) == ""} {
	    # ie: last command was anything _but_ an undo...
	    set undoIndex($w) [expr [llength $undo($w)] -1]
	}

	# if the index is pointing to a valid list element, 
	# lets undo it...
	if {$undoIndex($w) < 0} {
	    # nothing to undo...
	    bell

	} else {
	    
	    # data is a list comprised of a command token
	    # (i=insert, d=delete) and parameters related 
	    # to that token
	    set data [lindex $undo($w) $undoIndex($w)]

	    if {[lindex $data 0] == "d"} {
		set command "delete"
	    } else {
		set command "insert"
	    }
	    set args [lrange $data 1 end]

	    # adjust the index
	    incr undoIndex($w) -1

	}
    }

    # now, process the command (either the original one, or the morphed
    # undo command
    switch $command {

	reset_undo {
		set undo($w) ""
		set undoIndex($w) ""
		set result {}
	}

	configure {
	    # we have to deal with configure specially, since the
	    # user could try to configure the -preproc or -postproc
	    # options...
	    
	    if {[llength $args] == 0} {
		# first, the case where they just type "configure"; lets 
		# get it out of the way
		set list [$w configure]
		lappend list [list -preproc preproc Preproc {} $preProc($w)]
		lappend list [list -postproc postproc Postproc {} $postProc($w)]
		set result $list
		
		
	    } elseif {[llength $args] == 1} {
		# this means they are wanting specific configuration 
		# information
		set option [lindex $args 0]
		if {$option == "-preproc"} {
		    set result [list -preproc preproc Preproc {} $preProc($w)]

		} elseif {$option == "-postproc"} {
		    set result [list -postproc postproc Postproc {} $postProc($w)]
		    
		} else {
		    if {[catch "$w $command $args" result]} {
			regsub $w $result $this result
			return -code error $result
		    }
		}

	    } else {
		# ok, the user is actually configuring something... 
		# we'll deal with our special options first
		if {[set i [lsearch -exact $args "-preproc"]] >= 0} {
		    set j [expr $i + 1]
		    set preProc($w) [lindex $args $j]
		    set args [lreplace $args $i $j]
		    set result {}
		}

		if {[set i [lsearch -exact $args "-postproc"]] >= 0} {
		    set j [expr $i + 1]
		    set postProc($w) [lindex $args $j]
		    set args [lreplace $args $i $j]
		    set result {}
		}

		# now, process any remaining args
		if {[llength $args] > 0} {
		    if {[catch "$w $command $args" result]} {
			regsub $w $result $this result
			return -code error $result
		    }
		}
	    }
	}

	undo {
	    # if an undo command makes it to here, that means there 
	    # wasn't anything to undo; this effectively becomes a
	    # no-op
	    set result {}
	}

	insert {

	    if {[catch {set index  [text_index $w [lindex $args 0]]}]} {
		set index [lindex $args 0]
	    }

	    # since the insert command can have an arbitrary number
	    # of strings and possibly tags, we need to ferret that out
	    # now... what a pain!
	    set myargs [lrange $args 1 end]
	    set length 0
	    while {[llength $myargs] > 0} {
		incr length [string length [lindex $myargs 0]]
		if {[llength $myargs] > 1} {
		    # we have a tag...
		    set myargs [lrange $myargs 2 end]
		} else {
		    set myargs [lrange $myargs 1 end]
		}
	    }

	    # now, let the real widget command do the dirty work
	    # of inserting the text. If we fail, do some munging 
	    # of the error message so the right widget name appears...

	    if {[catch "$w $command $args" result]} {
		regsub $w $result $this result
		return -code error $result
	    }

	    # we need this for the undo stack; index2 couldn't be
	    # computed until after we inserted the data...
	    set index2 [text_index $w "$index + $length chars"]

	    if {$originalCommand == "undo"} {
		# let's do a "see" so what we just did is visible;
		# also, we'll move the insertion cursor to the end
		# of what we just did...
		$w see $index2
		$w mark set insert $index2
		
	    } else {
		# since the original command wasn't undo, we need
		# to reset the undoIndex. This means that the next
		# time an undo is called for we'll start at the 
		# end of the stack
		set undoIndex($w) ""
	    }

	    # add a delete command on the undo stack.
	    lappend undo($w) "d $index $index2"

	}

	delete {

	    # this converts the insertion index into an absolute address
	    set index [text_index $w [lindex $args 0]]

	    # lets get the data we are about to delete; we'll need
	    # it to be able to undo it (obviously. Duh.)
	    set data [eval $w get $args]

	    # add an insert on the undo stack
	    lappend undo($w) [list "i" $index $data]

	    if {$originalCommand == "undo"} {
		# let's do a "see" so what we just did is visible;
		# also, we'll move the insertion cursor to a suitable
		# spot
		$w see $index
		$w mark set insert $index

	    } else {
		# since the original command wasn't undo, we need
		# to reset the undoIndex. This means that the next
		# time an undo is called for we'll start at the 
		# end of the stack
		set undoIndex($w) ""
	    }

	    # let the real widget command do the actual deletion. If
	    # we fail, do some munging of the error message so the right
	    # widget name appears...
	    if {[catch "$w $command $args" result]} {
		regsub $w $result $this result
		return -code error $result
	    }
	}
	
	default {
	    # if the command wasn't one of the special commands above,
	    # just pass it on to the real widget command as-is. If
	    # we fail, do some munging of the error message so the right
	    # widget name appears...
	    if {[catch "$w $command $args" result]} {
		regsub $w $result $this result
		return -code error $result
	    }
	}
    }

    # is there a post-proc? If so, run it. 
    if {[info exists postProc($w)] && $postProc($w) != ""} {
	if {[catch "$postProc($w) originalCommand originalArgs" error]} {
	    return -code error "error during processing of -postproc: $error"
	}
    }


    # we're outta here! (I think this is faster than a 
    # return, though I'm not 100% sure on this...)
    set result $result
}

# this returns a normalized index (ie: line.column), with special
# handling for the index "end"; to undo something we pretty much
# _have_ to have a precise row and column number.
proc supertext::text_index {w i} {
    if {$i == "end"} {
	set index [$w index "end-1c"]
    } else {
	set index [$w index $i]
    }

    return $index
}