#! /bin/sh
# main.tcl
# $Id: main.tcl,v 1.17 2001/03/19 01:01:46 golem Exp $
# The entry point for xed.
#
#
# XED --- an X-enabled implementation of ed, the standard editor.
# Copyright (C) 1999  Chris Laas
# 
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# 
# Chris Laas
# golem@mit.edu
# 22 Pratt Court
# Cohasset, MA 02025 USA
#
#
# The next lines bootstrap us into wish or tclsh. \
trap "" 21 ;\
TCLSH=tclsh ;\
for ver in 8.3 8.2 8.1 ; do \
 if type tclsh$ver >/dev/null 2>&1 ; then TCLSH=tclsh$ver ; break ; fi ;\
done ;\
WISH=wish ;\
for ver in 8.3 8.2 8.1 ; do \
 if type wish$ver >/dev/null 2>&1 ; then WISH=wish$ver ; break ; fi ;\
done ;\
if [ x$DISPLAY = x ]; then exec $TCLSH $0 -ttymode "$@" ; fi ;\
for arg in "$@" ; do \
 if [ x$arg = x-t -o x$arg = x-ttymode ]; then exec $TCLSH $0 "$@" ; fi ;\
done ;\
exec $WISH $0 "$@"

##########################
# The tcl code begins here.

set VERSION 0.9.1



if {$tcl_version < 8.1} {
    error "xed requires at least TCL version 8.1 to run properly."
}



set is_tclet [info exists embed_args]
if $is_tclet { proc wm args {} }


##########################
# Command line handling.
set verbose 1
set prompt ""

set backup_files 1
set playback 0
set ttymode 0
set debug 0
set init_file ""

proc usage {} {
	puts {Usage: xed [OPTION]... [FILE]

  -s                 suppress diagnostics
  -p STRING          use STRING as an interactive prompt

  -nb                don't back up files before save
  -P                 go into playback mode: read lines from stdin into GUI
  -ttymode           do not start up X GUI
  -fn FONT           use FONT for GUI
  -x N               set tab stops at every N spaces in GUI
  -nwl               don't wrap lines in GUI
  -nsb               don't show scrollbar in GUI
  -help              display this help
  -version           output version information

Starts editing with the command "e FILE" if given.}
}

set skipnext 0
foreach arg1 $argv arg2 [lrange $argv 1 end] {
	if $skipnext { set skipnext 0 ; continue }
	switch -glob -- $arg1 {
		-s { set verbose 0 }
		-p { set prompt $arg2 ; set skipnext 1 }

		-nb      { set backup_files 0 }
		-P       { set playback 1 }
		-ttymode { set ttymode 1 ; set line_source tty }
		-fn      { option add *font $arg2 interactive ; set skipnext 1 }
		-x       { option add *tabWidth $arg2 interactive ; set skipnext 1 }
		-nwl     { option add *wrapLines off interactive }
		-nsb     { option add *scrollbar off interactive }
		-debug   { set debug 1 }
		-bgerror { proc bgerror {msg} { puts stderr $msg } }
		-help    { usage ; exit 0 }
		-version { puts "xed version $VERSION" }
		-* {
			puts stderr "xed: Unrecognized option \"$arg1\""
			puts stderr "Try \"xed -help\" for more information."
			exit 1
		}
		default { set init_file $arg1 }
	}
}

if {$playback && $ttymode} {
	puts stderr "xed: Cannot do playback in ttymode.  Aborting."
	exit 1
}



##############################################################
# Here we have the files which contain the real guts of xed.
# parse.tcl
# $Id: parse.tcl,v 1.9 1999/07/28 07:51:56 chris Exp $
# Parses command lines.  Yes, in Tcl.  *duck*
#
#
# XED --- an X-enabled implementation of ed, the standard editor.
# Copyright (C) 1999  Chris Laas
# 
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# 
# Chris Laas
# golem@mit.edu
# 22 Pratt Court
# Cohasset, MA 02025 USA


array set handlers {
	a command-append
	c command-change
	d command-delete
	e command-edit-or-read-file E command-edit-or-read-file
	f command-default-filename
	g command-match
	G command-match
	H command-toggle-errors
	h command-last-error
	i command-insert
	j command-join
	k command-mark
	m command-move
	l command-print n command-print p command-print
	P command-toggle-prompt
	q command-quit Q command-quit
	r command-edit-or-read-file
	s command-substitute
	t command-transfer
	u command-undo
	v command-match
	V command-match
	w command-write-file W command-write-file
	x command-put-cut-buffer y command-yank-cut-buffer
	z command-scroll
	! command-shell
	# command-comment
	= command-print-line-number
	{} command-print-line

	~ command-eval-tcl

	C command-change-interactive
	| command-pipe
	I command-indent
}
array set default_ranges {
	a . c . d . e {} E {} f {} g 1,$ G 1,$ h {} H {}
	i . j .,.+1 k . l . m . n . p . P {} q {} Q {}
	r $ s . t . u {} v 1,$ V 1,$ w 1,$ W 1,$ x . y . z .+1
	! {} . {} = $ {} .+1

	~ {}

	C . | 1,$ I .
}


set command_list {}
set this_undo_commands {}
set last_undo_commands {}

proc process-line {line} {
	global prompt verbose default_filename current_addr last_addr dirty \
			debug input_mode handlers default_ranges ttymode confirm \
			command_list last_command_list continuation \
			this_undo_commands last_undo_commands
	switch -exact -- [lindex $input_mode 0] {
		command - subcommand - batchcommand {
			set script {
				if {[lindex $input_mode 0] == "command"} {
					set last_undo_commands $this_undo_commands
					set this_undo_commands [list \
							"~set dirty $dirty" \
							"~set prompt {$prompt}" \
							"~set default_filename {$default_filename}" \
							"~set current_addr $current_addr"]
				} elseif {[lindex $input_mode 0] == "subcommand"} {
					if {$command_list == {} && $line == {}} {
						set input_mode [lrange $input_mode 1 end]
						return
					}
					if {$command_list == {} && $line == "&"} {
						if {![info exists last_command_list]} {
							error "No previous command list"
						}
						foreach line $last_command_list { process-line $line }
						return
					}
					if ![regsub {\\$} $line {} line] {
						set input_mode [lrange $input_mode 1 end]
						set last_command_list [concat $command_list $line]
						set command_list {}
					} else {
						lappend command_list $line
					}
				}
				# Note that batchcommand has no special processing.

				read-addr-range $line line addr1 addr2
				set command [string index $line 0]
				set rest [string trim [string range $line 1 end]]
				if {![info exists handlers($command)]} {
					error "Invalid command $line"
				}
				if {![string match {[eEqQ]} $command]} { set confirm {} }
				if {$addr1 == {} && $default_ranges($command) != {}} {
					read-addr-range $default_ranges($command) junk \
							addr1 addr2
				}
				$handlers($command) $addr1 $addr2 $command $rest
			}
			if $debug {
				eval $script
			} else {
				switch [catch $script error] {
					1 {
						# TCL_ERROR
						if $verbose {
							puts-error $error
						} else {
							puts-error ?
						}
						set last_error $error
					}
					2 { return }
				}
			}
		}
		continuation {
			set continuation $line
			set input_mode [lrange $input_mode 1 end]
		}
		text {
			if {$line == "."} {
				set input_mode [lrange $input_mode 1 end]
			} else {
				buffer-put $current_addr $line
				incr current_addr
				incr last_addr
				set dirty 1
			}
		}
	}
}

proc read-addr-range {linein linevar addr1var addr2var} {
	upvar 1 $linevar line $addr1var addr1 $addr2var addr2
	global current_addr last_addr
	set line [string trimleft $linein]
	set addrlist {}
	while 1 {
		set match [read-addr $line line addr]
		switch -exact -- [string index $line 0] {
			, - % {
				# Effectively, % is the same as , .  Read the GNU ed source.
				if $match {
					lappend addrlist $addr
				} else {
					if {$addrlist != {}} {
						lappend addrlist $last_addr
					} else {
						set addrlist [list 1 $last_addr]
					}
				}
				set line [string range $line 1 end]
			}
			; {
				if $match {
					set current_addr $addr
					lappend addrlist $addr
				} else {
					if {$addrlist != {}} {
						lappend addrlist $last_addr
					} else {
						set addrlist [list $current_addr $last_addr]
					}
				}
				set line [string range $line 1 end]
			}
			default { if $match { lappend addrlist $addr } ; break }
		}
	}
	switch [llength $addrlist] {
		0 { set addr1 {} ; set addr2 {} }
		1 { set addr1 [lindex $addrlist 0] ; set addr2 $addr1 }
		default {
			set addr1 [lindex $addrlist [expr [llength $addrlist] - 2]]
			set addr2 [lindex $addrlist [expr [llength $addrlist] - 1]]
			if {$addr1 > $addr2} {
				error "Invalid address range, must be in ascending order"
			}
		}
	}
}

proc read-addr {linein linevar addrvar} {
	upvar 1 $addrvar addr $linevar line
	global current_addr last_addr last_regexp
	set line [string trimleft $linein]
	set matched 1
	switch -exact -- [string index $line 0] {
		0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
			regexp {^([0-9]+)(.*)$} $line garbage addr line
		}
		. { set addr $current_addr ; set line [string range $line 1 end] }
		$ { set addr $last_addr    ; set line [string range $line 1 end] }
		/ {
			set regexp [regexp-compile [parse-pattern line delimiter]]
			set addr [buffer-search-forwards  $regexp [expr $current_addr+1]]
		}
		? {
			set regexp [regexp-compile [parse-pattern line delimiter]]
			set addr [buffer-search-backwards $regexp [expr $current_addr-1]]
		}
		' {
			set c [string index $line 1]
			set addr [buffer-mark-get $c]
			if {$addr == {}} { error "No such mark \"$c\"" }
			set line [string range $line 2 end]
		}
		default { set matched 0 }
	}
	while 1 {
		switch -exact -- [string index $line 0] {
			" " - \t - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {
				if {[regexp {^[ \t]*([0-9]+)(.*)$} $line junk i line]} {
					if {!$matched} { set addr 0 ; set matched 1 }
					incr addr $i
				} else {
					set line [string trimleft $line]
				}
			}
			+ {
				if {!$matched} { set addr $current_addr ; set matched 1 }
				if {[regexp {^\+[ \t]*([0-9]+)(.*)$} $line junk i line]} {
					incr addr $i
				} else {
					incr addr
					set line [string range $line 1 end]
				}
			}
			- - ^ {
				if {!$matched} { set addr $current_addr ; set matched 1 }
				if {[regexp {^[-^][ \t]*([0-9]+)(.*)$} $line junk i line]} {
					incr addr -$i
				} else {
					incr addr -1
					set line [string range $line 1 end]
				}
			}
			default { break }
		}
	}
	if {$matched && ($addr < 0 || $last_addr < $addr)} {
		error "Address out of range: [string range $linein 0 [expr \
				[string length $linein] - [string length $line] - 1]] == $addr"
	}
	return $matched
}


######################################################################
# batch-process-lines

set batching 0
proc batch-process-lines {list} {
	global batching batch_lines
	if {$batching} {
		error "Cannot nest batched functions such as g, v, and u"
	}
	set batching 1
	set batch_lines $list
	after idle batch-process-line
	vwait batching
}
proc batch-process-line {} {
	global batching batch_lines
	if {[llength $batch_lines] == 0} {
		set batching 0
	} else {
		set id [after idle batch-process-line]
		set line [lindex $batch_lines 0]
		set batch_lines [lrange $batch_lines 1 end]
		process-line $line
	}
}
# command.tcl
# $Id: command.tcl,v 1.16 1999/07/31 00:33:37 chris Exp $
# Handles the various ed commands.
#
#
# XED --- an X-enabled implementation of ed, the standard editor.
# Copyright (C) 1999  Chris Laas
# 
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# 
# Chris Laas
# golem@mit.edu
# 22 Pratt Court
# Cohasset, MA 02025 USA


set default_filename ""
set current_addr 0
set last_addr 0
set dirty 0
set input_mode command
set confirm ""
set last_error ""
array set subst {global 0 pflags {}}


# Line printing subsystem.
for {set i 1} {$i < 256} {incr i} {
	set p [format {\%03o} $i]
	set unambiguous([subst -nocommands -novariables $p]) $p
}
for {set i 32} {$i < 127} {incr i} {
	set c [subst -nocommands -novariables [format {\%03o} $i]]
	set unambiguous($c) $c
}
foreach special {a b f n r t v} {
	set unambiguous([subst -nocommands -novariables \\$special]) \\$special
}
set unambiguous(\\) "\\\\"
proc print-lines {addr1 addr2 flags} {
	global unambiguous current_addr

	if {$addr1 == {}} { set addr1 $current_addr }
	if {$addr2 == {}} { set addr2 $addr1 }

	set f_p 0
	set f_l 0
	set f_n 0
	while {$flags != {}} {
		switch -exact [string index $flags 0] \
				p { set f_p 1 } l { set f_l 1 } n { set f_n 1 } \
				default { error "Invalid command suffix" }
		set flags [string range $flags 1 end]
	}
	if {!$f_p && !$f_l && !$f_n} { return }

	set out {}
	set n [expr $addr1-1]

	set lines [buffer-get $addr1 $addr2]
	if {$lines == {}} { set lines {{}} } else { set lines [split $lines \n] }
	foreach line $lines {
		if $f_l {
			set newline {}
			foreach c [split [string trimright $line \n] {}] {
				append newline $unambiguous($c)
			}
			set line $newline\$
		}
		if $f_n {
			append out [format "%-7d %s\n" [incr n] $line]
		} else {
			append out $line\n
		}
	}
	puts-response [string trimright $out \n]
}



# The a command.
proc command-append {addr1 addr2 command line} {
	global input_mode current_addr
	if {[string tolower $line] == "bout"} { easter-egg ; return }
	set current_addr $addr2
	set input_mode "text $input_mode"
	vwait input_mode
	print-lines {} {} $line
}
proc easter-egg {} {
	global M1 M2 G L K y1 y2 v1 v2 xe entry_line old_entry_line VERSION \
		line_source
	set about_message "Xed version $VERSION    by Chris Laas <golem@mit.edu>    Copyright (c) 1999"

	if {$line_source == "stdin"} { puts-response $about_message ; return }

	set M1 10
	set M2 0.01
	set G -0.0003
	set L 0.8
	set K 0.01
	
	set M1 1
	set M2 0.2
	set G -0.0003
	set L 0.6
	set K 0.002

	set y1 1.0
	set y2 [expr $y1 - $L]
	set v1 0.0
	set v2 0.0
	
	set xe 0.0

	proc egg-step {} {
		global M1 M2 G L K y1 y2 v1 v2 xe
		set new_y1 [expr $y1 + $v1]
		set new_y2 [expr $y2 + $v2]
		set new_y1 [expr $new_y1 >= 1.0 ? 1.0 : $new_y1 <= 0.0 ? 0.0 : $new_y1]
		set new_y2 [expr $new_y2 >= 1.0 ? 1.0 : $new_y2 <= 0.0 ? 0.0 : $new_y2]
		set y1 $new_y1
		set y2 $new_y2
		if {$new_y1 == 0.0 || $new_y1 == 1.0} { set v1 0.0 }
		if {$new_y2 == 0.0 || $new_y2 == 1.0} { set v2 0.0 }
		set springf [expr $K * ($L - abs($y2 - $y1)) * ($y1 > $y2 ? 1.0 : -1.0)]
		set v1 [expr $v1 + $G + $springf / $M1]
		set v2 [expr $v2 + $G - $springf / $M2]
	
		.ysb set [expr 1.0 - $y1] [expr 1.0 - $y2]

		set xe [expr $xe - ($v1 < 0.0 ? $v1 / 8.0 : $v1 / 16.0)]
		.e xview moveto $xe
	}

	foreach child [winfo children .] {
		bindtags $child [concat egg_wait [bindtags $child]]
	}
	
	set old_entry_line $entry_line
	set entry_line {                                                                                                                                                                }
	set l [.e xview]
	set entry_line [string range $entry_line 0 [expr int(([lindex $l 1] - [lindex $l 0]) * [string length $entry_line])]]
	append entry_line $about_message$entry_line

	proc egg-tick {} { egg-step ; global id ; set id [after 10 egg-tick] }
	egg-tick

	set script {
		after cancel $id
		set entry_line $old_entry_line
		eval ".ysb set [.t yview]"
		foreach child [winfo children .] {
			bindtags $child [lrange [bindtags $child] 1 end]
		}
	}
	bind egg_wait <Key>    $script
	bind egg_wait <Button> $script
}

# The c command.
proc command-change {addr1 addr2 command line} {
	command-delete $addr1 $addr2 d {}
	command-append [expr $addr1-1] [expr $addr1-1] a $line
}

# The d command.
proc command-delete {addr1 addr2 command line} {
	global current_addr last_addr cut_buffer dirty
	if {$addr1 == 0} { error "Address out of range, cannot delete address 0" }

	set cut_buffer [buffer-get $addr1 $addr2]

	buffer-delete $addr1 $addr2
	incr last_addr [expr $addr1-$addr2-1]
	set current_addr $addr1
	if {$current_addr > $last_addr} { set current_addr $last_addr }
	set dirty 1
	print-lines {} {} $line
}

# The e, E, and r commands.
proc command-edit-or-read-file {addr1 addr2 command line} {
	global is_tclet default_filename current_addr last_addr dirty confirm

	if $is_tclet { error "Reading files is not permitted in a Tclet" }

	if {$dirty && $command == "e"} {
		if {$confirm == "command-edit-or-read-file"} {
			set confirm ""
		} else {
			set confirm "command-edit-or-read-file"
			error "Warning: file modified"
		}
	}

	if {$line == ""} {
		set file $default_filename
	} elseif {[string match |* $line]} {
		set file \\$line
	} elseif {[string match !* $line]} {
		set file [list |sh -c [string range $line 1 end]]
	} else {
		set file $line
	}

	set f [open $file r]
	if {$command == "e" || $command == "E"} {
		buffer-clear
		set addr2 0
		set last_addr 0
	} elseif {$command == "r"} {
		# Insert at address.
	} else {
		error "Internal error"
	}
	set addr $addr2
	set bytecount 0
	while {![eof $f]} {
		set fileline [gets $f]
		# Ignore a trailing empty line.
		if {$fileline == "" && [eof $f]} { break }
		incr bytecount [string length $fileline]
		# A byte for the newline.
		incr bytecount
		buffer-put $addr $fileline
		incr addr
	}
	close $f

	set current_addr $addr
	incr last_addr [expr $addr - $addr2]
	if {$command == "e" || $command == "E"} {
		set dirty 0
		if {![string match !* $line]} { set default_filename $file }
	} elseif {$command == "r"} {
		set dirty 1
		if {![string match !* $line] && $default_filename == ""} {
			set default_filename $file
		}
	} else {
		error "Internal error"
	}

	puts-response $bytecount
}

# The f command.
proc command-default-filename {addr1 addr2 command line} {
	global default_filename
	if {[string match |* $line]} { set line \\$line }
	if {$line != ""} { set default_filename $line }
	puts-response $default_filename
}

# The g, v, G, and V commands.
proc command-match {addr1 addr2 command line} {
	global current_addr input_mode continuation
	if {$addr1 == 0} {
		error "Address out of range, cannot search on address 0"
	}

	if {[string length $line] == 0} { error "Invalid pattern delimiter" }
	set regexp [regexp-compile [parse-pattern line delimiter]]

	if {$command == "g" || $command == "v"} {
		while {[regsub {\\$} $line "\n" line]} {
			set input_mode "continuation $input_mode"
			vwait input_mode
			append line $continuation
		}
		set commands [split $line \n]
	}

	set count 0
	if {$command == "g" || $command == "G"} {
		while {[set addr [buffer-search-forwards $regexp $addr1 $addr2]]!={}} {
			buffer-mark-set _[incr count] $addr
			set addr1 [expr $addr + 1]
		}
	} else {
		set next_match [buffer-search-forwards $regexp $addr1 $addr2]
		for {set addr $addr1} {$addr <= $addr2} {set addr $addr1} {
			if {$addr == $next_match} {
				set next_match [buffer-search-forwards $regexp $addr1 $addr2]
			} else {
				buffer-mark-set _[incr count] $addr
			}
			set addr1 [expr $addr + 1]
		}
	}

	if {$command == "g" || $command == "v"} {
		set input_mode "batchcommand $input_mode"
	}

	for {set i 1} {$i <= $count} {incr i} {
		if [catch { set current_addr [buffer-mark-get _$i] } error] {continue}
		if {$command == "g" || $command == "v"} {
			batch-process-lines $commands
		} else {
			print-lines {} {} p
			set input_mode "subcommand $input_mode"
			vwait input_mode
		}
	}

	if {$command == "g" || $command == "v"} {
		set input_mode [lrange $input_mode 1 end]
	}
}

# The H command.
proc command-toggle-errors {addr1 addr2 command line} {
	global verbose last_error
	if {$verbose} {
		set verbose 0
	} else {
		set verbose 1
		puts-error $last_error
	}
	print-lines {} {} $line
}

# The h command.
proc command-last-error {addr1 addr2 command line} {
	global last_error
	puts-error $last_error
	print-lines {} {} $line
}

# The i command.
proc command-insert {addr1 addr2 command line} {
	if {$addr2 == 0} {
		error "Address out of range, cannot insert before address 0"
	}
	incr addr2 -1
	command-append $addr2 $addr2 a $line
}

# The j command.
proc command-join {addr1 addr2 command line} {
	global current_addr last_addr cut_buffer dirty
	if {$addr1 == 0} { error "Address out of range, cannot join address 0" }
	set cut_buffer [buffer-get $addr1 $addr2]
	regsub -all \n $cut_buffer {} new_line
	buffer-delete $addr1 $addr2
	buffer-put [expr $addr1-1] $new_line
	incr last_addr [expr $addr1-$addr2]
	set current_addr $addr1
	set dirty 1
	print-lines {} {} $line
}

# The k command.
proc command-mark {addr1 addr2 command line} {
	buffer-mark-set [string index $line 0] $addr2
}

# The m command.
proc command-move {addr1 addr2 command line} {
	global current_addr last_addr dirty
	if {$addr1 == 0} {
		error "Address out of range, cannot move from address 0"
	}
	read-addr-range $line line daddr1 daddr2
	if {$daddr2 == {}} { set daddr2 $current_addr }
	set text [buffer-get $addr1 $addr2]
	buffer-delete $addr1 $addr2
	if {$daddr2 < $addr1} {
		buffer-put $daddr2 $text
		set current_addr [expr $daddr2+1+$addr2-$addr1]
	} elseif {$daddr2 >= $addr2} {
		buffer-put [expr $daddr2-1-$addr2+$addr1] $text
		set current_addr $daddr2
	} else {
		error "Invalid destination, lies in source range"
	}
	set dirty 1
	print-lines {} {} $line
}

# The p, l, and n commands.
proc command-print {addr1 addr2 command line} {
	global current_addr
	print-lines $addr1 $addr2 $command$line
	set current_addr $addr2
}

# The P command.
proc command-toggle-prompt {addr1 addr2 command line} {
	global prompt
	if {$prompt == ""} {
		set prompt *
	} else {
		set prompt ""
	}
	print-lines {} {} $line
}

# The q and Q commands.
proc command-quit {addr1 addr2 command line} {
	global dirty confirm
	if {$dirty && $command == "q"} {
		if {$confirm == "command-quit"} {
			set confirm ""
		} else {
			set confirm "command-quit"
			error "Warning: file modified"
		}
	}
	exit
}

# The s command.
proc command-substitute {addr1 addr2 command line} {
	global current_addr last_addr cut_buffer dirty
	global subst
	if {$addr1 == 0} {
		error "Address out of range, cannot substitute on address 0"
	}

	# Detect the second (repeat last substitution) form of the command.
	if {$line == {} || [regexp {^[gprln0-9]} $line]} {
		if {![info exists subst(pat)]} { error "No previous substitution" }
		set sgnum 0
		while {$line != {}} {
			if {![regexp {^([gprln]|[0-9]+)(.*)} $line junk flag line]} {
				error "Invalid command suffix"
			}
			switch $flag {
				g {
					set sgnum 0
					set subst(global) [expr !$subst(global)]
				}
				r { error "r suffix unimplemented --- can't figure out what it's supposed to do." }
				p { set subst(pflags) [expr {$subst(pflags)=={} ? "p" : {}}] }
				l - n { append subst(pflags) p$flag }
				default { set sgnum $flag }
			}
		}
	} else {
		if {[string length $line] == 0} { error "Invalid pattern delimiter" }
		set subst(pat) [regexp-compile [parse-pattern line delimiter]]
		set subst(template) [parse-subst-template line $delimiter]
		set sgnum 0
		set subst(pflags) {}
		set subst(global) 0
		if {$line == {}} {
			set subst(pflags) p
		} else {
			set line [string range $line 1 end]
			while {$line != {}} {
				if {![regexp {^([gpln]|[0-9]+)(.*)} $line junk flag line]} {
					error "Invalid command suffix"
				}
				switch $flag {
					g {
						set sgnum 0
						set subst(global) 1
					}
					p - l - n { append subst(pflags) $flag }
					default { set sgnum $flag }
				}
			}
		}
	}

	while {[set addr [buffer-search-forwards $subst(pat) $addr1 $addr2]]!={}} {
		set text [buffer-get $addr $addr]
		set bufr $text
		set bufl {}
		for {set i 1} {$i < $sgnum} {incr i} {
			if ![regexp -indices -- $subst(pat) $bufr indices] { break }
			append bufl [string range $bufr 0 [lindex $indices 1]]
			set bufr [string range $bufr [expr [lindex $indices 1]+1] end]
		}
		if {$i < $sgnum} { continue }

		if {$bufr == {}} {
			# The regsub command deals incorrectly with an empty input:
			# for example, the pattern ^ doesn't match the empty input.
			# Thus, we special-case it.
			set result [regexp -- $subst(pat) {}]
			if $result {
				# It matched, as we expected.  Set $bufr to $subst(template),
				# replacing "&" and "\n" (where n==0..9) with the empty string.
				regsub -all -- {&|\\[0-9]} $subst(template) {} bufr
			}
		} else {
			if $subst(global) {
				set result [regsub -all -- $subst(pat) $bufr $subst(template) bufr]
			} else {
				set result [regsub      -- $subst(pat) $bufr $subst(template) bufr]
			}
		}
		if {$sgnum == 0 && $result == 0} {
			error "Internal error: false regexp match"
		}

		set buffer $bufl$bufr
		buffer-delete $addr $addr
		buffer-put [expr $addr-1] $buffer

		if {$buffer == {}} {
			set newlines 0
		} else {
			set newlines [expr [llength [split $buffer \n]] - 1]
		}
		incr addr1 $newlines
		incr addr2 $newlines
		incr last_addr $newlines

		set cut_buffer $text
		set dirty 1
		set current_addr $addr

		set addr1 [expr $addr + 1]
	}

	print-lines {} {} $subst(pflags)
}

# The t command.
proc command-transfer {addr1 addr2 command line} {
	global current_addr last_addr dirty
	if {$addr1 == 0} {
		error "Address out of range, cannot transfer from address 0"
	}
	read-addr-range $line line daddr1 daddr2
	if {$daddr2 == {}} { set daddr2 $current_addr }
	buffer-put $daddr2 [buffer-get $addr1 $addr2]
	set lines [expr $addr2-$addr1+1]
	incr last_addr $lines
	set current_addr [expr $daddr2+$lines]
	set dirty 1
	print-lines {} {} $line
}

# The u command.
proc command-undo {addr1 addr2 command line} {
	global last_undo_commands input_mode

	set input_mode "batchcommand $input_mode"
	batch-process-lines $last_undo_commands
	set input_mode [lrange $input_mode 1 end]

	print-lines {} {} $line
}

# The w and W commands.
proc command-write-file {addr1 addr2 command line} {
	global is_tclet default_filename current_addr last_addr confirm dirty
	global backup_files

	if $is_tclet { error "Writing files is not permitted in a Tclet" }

	set quit 0
	if {$line == "q" || [string match "q\[ \t\n\]*" $line]} {
		set quit 1
		set line [string trim [string range $line 2 end]]
	}

	if {$line == ""} {
		set file $default_filename
	} elseif {[string match |* $line]} {
		set file \\$line
	} elseif {[string match !* $line]} {
		set file [list |sh -c [string range $line 1 end]]
	} else {
		set file $line
	}

	if {$command == "W"} {
		set mode a
	} elseif {$command == "w"} {
		set mode w
	} else {
		error "Internal error"
	}

	catch {
		if {$backup_files && [file isfile $file]} {
			if {![file exists $file~]   && [file writable [file dirname $file]]
				|| [file isfile $file~] && [file writable $file~]} {
				file rename -force -- $file $file~
				file copy   -force -- $file~ $file
			}
		}
	}

	set f [open $file $mode]
	set text [buffer-get $addr1 $addr2]
	puts $f $text
	close $f

	if {$default_filename == ""} {
		if {[string match |* $line]} { set line \\$line }
		if {$line != ""} { set default_filename $line }
	}

	set dirty 0

	puts-response [string length $text]

	if $quit { exit }
}

# The x command.
proc command-put-cut-buffer {addr1 addr2 command line} {
	global cut_buffer current_addr last_addr dirty
	if {![info exists cut_buffer]} { error "Nothing to put" }
	buffer-put $addr2 $cut_buffer
	set lines [llength [split $cut_buffer \n]]
	if {$lines == 0} { set lines 1 }
	set current_addr [expr $addr2+$lines]
	incr last_addr $lines
	set dirty 1
	print-lines {} {} $line
}

# The y command.
proc command-yank-cut-buffer {addr1 addr2 command line} {
	global cut_buffer
	set cut_buffer [buffer-get $addr1 $addr2]
	print-lines {} {} $line
}

# The z command.
proc command-scroll {addr1 addr2 command line} {
	global line_source current_addr last_addr
	if {![regexp {^([0-9]+)(.*)} $line junk count line]} {
		switch $line_source {
			stdin {
				set stty [exec stty -a]
				if {![regexp {rows[ \t]*=[ \t]*([0-9]+)} $stty junk count]} {
					set count 24
				}
				# Take into account the last line of the terminal will be blank.
				set count [expr $count - 1]
			}
			X {
				set count 1
			}
		}
	}
	set addr1 $addr2
	if {$addr2+$count-1 > $last_addr} {
		set current_addr $last_addr
	} else {
		set current_addr [expr $addr2+$count-1]
	}
	print-lines $addr1 $current_addr p$line
}

# The ! command.
proc command-shell {addr1 addr2 command line} {
	global is_tclet last_shell_command default_filename

	if $is_tclet { error "Executing programs is not permitted in a Tclet" }

	if {[string index $line 0] == "!"} {
		if [catch {set line $last_shell_command[string range $line 1 end]}] {
			error "No previous shell command"
		}
	}
	regsub {%} $line $default_filename line
	exec sh -c $line <@stdin >@stdout 2>@stderr
	puts-response !
}

# The # command.
proc command-comment {addr1 addr2 command line} {
	# Does absolutely nothing.
}

# The = command.
proc command-print-line-number {addr1 addr2 command line} {
	puts-response $addr2
	print-lines {} {} $line
}

# The null command.  (When nothing but an address is typed.)
proc command-print-line {addr1 addr2 command line} {
	global current_addr last_addr
	if {$addr2 == 0} { error "Address out of range, cannot print address 0" }
	set current_addr $addr2
	puts-response [buffer-get $current_addr $current_addr]
}

# The ~ command, which is used in the undo system, and which I
# use for debugging.
proc command-eval-tcl {addr1 addr2 command line} {
	puts-response [uplevel #0 $line]
}
# nonstd-cmds.tcl
# $Id: nonstd-cmds.tcl,v 1.5 1999/07/28 09:01:18 chris Exp $
# Handles nonstandard extension commands.
#
#
# XED --- an X-enabled implementation of ed, the standard editor.
# Copyright (C) 1999  Chris Laas
# 
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# 
# Chris Laas
# golem@mit.edu
# 22 Pratt Court
# Cohasset, MA 02025 USA


# The C command.
# This is an inherently GUI command; the tty version is near-useless.
proc command-change-interactive {addr1 addr2 command line} {
	global line_source entry_line input_mode current_addr last_addr \
		cut_buffer dirty
	if {$addr1 == 0} {
		error "Address out of range, cannot interactively change address 0"
	}

	set cut_buffer [buffer-get $addr1 $addr2]
	set current_addr [expr $addr1-1]
	if {$cut_buffer == {}} { set lines {{}} } else { set lines [split $cut_buffer \n] }
	foreach bufline $lines {
		buffer-delete [expr $current_addr+1] [expr $current_addr+1]
		incr last_addr -1
		switch $line_source {
			stdin { puts-response $bufline }
			X { after idle [list set entry_line $bufline] ; raise .e }
		}
		set input_mode "text $input_mode"
		vwait dirty
		set input_mode [lrange $input_mode 1 end]
	}

	set dirty 1
	print-lines {} {} $line
}

# The | command.
proc command-pipe {addr1 addr2 command line} {
	global is_tclet last_pipe_command default_filename
	global current_addr last_addr cut_buffer dirty

	if $is_tclet { error "Executing programs is not permitted in a Tclet" }

	if {[string index $line 0] == "|"} {
		if ![info exists last_pipe_command] {
			error "No previous pipe command"
		}
		set line $last_pipe_command[string range $line 1 end]
	}
	regsub {%} $line $default_filename line

	set in_lines [buffer-get $addr1 $addr2]
	set f [open |[list sh -c $line <<$in_lines 2>@stderr] r]
	while {![eof $f]} { lappend out_lines [gets $f] }
	close $f

	set cut_buffer $in_lines
	buffer-delete $addr1 $addr2
	buffer-put [expr $addr1 - 1] [join $out_lines \n]

	set current_addr [expr $addr1 - 1 + [llength $out_lines]]
	set last_addr [expr $last_addr - ($addr2-$addr1) + [llength $out_lines]-1]

	set dirty 1
	puts-response !
}

# The I command.
proc command-indent {addr1 addr2 command line} {
	global current_addr dirty

	if {$addr1 == 0} {
		error "Address out of range, cannot indent address 0"
	}

	set addr $addr1
	while 1 {
		incr addr -1
		if {$addr == 0} { set bufline {} ; set indent {} ; break }
		set bufline [buffer-get $addr $addr]
		if {$bufline != {}} { regexp "^(\t*)" $bufline indent ; break }
	}
	for {set addr $addr1} {$addr <= $addr2} {incr addr} {
		switch -- [string range $bufline end end] \{ - \\ {
			append indent \t
		}
		set bufline [buffer-get $addr $addr]
		if {$bufline == {}} { continue }
		if {[string index [string trimleft $bufline] 0] == "\}"} {
			set indent [string range $indent 1 end]
		}
		if {$bufline != "$indent[string trimleft $bufline]"} {
			buffer-delete $addr $addr
			buffer-put [expr $addr-1] $indent[string trimleft $bufline]
			set dirty 1
			set current_addr $addr
		}
	}

	print-lines {} {} $line
}
# buffer.tcl
# $Id: buffer.tcl,v 1.16 1999/07/31 00:33:36 chris Exp $
# Handles the line buffer, and also handles I/O.
# I'd love to draw an abstraction barrier here, but find
# this difficult because the buffer is stored in the text
# widget in X mode.
#
#
# XED --- an X-enabled implementation of ed, the standard editor.
# Copyright (C) 1999  Chris Laas
# 
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# 
# Chris Laas
# golem@mit.edu
# 22 Pratt Court
# Cohasset, MA 02025 USA



######################################################################
# Procedures that form an abstraction barrier for interaction with
# the line buffer.

proc both-buffer-init {} {
	global is_tclet playback
	if {!$is_tclet && !$playback} {
		fconfigure stdin -blocking false
		fileevent stdin readable {
			# The nonblocking code _should_ deal with TTIN
			# gracefully, but it doesn't (under linux and netbsd;
			# it works fine under solaris without this frobbing).
			# Consequently, I must trap TTIN in the header of
			# main.tcl, and trap the resultant I/O error here.
			if {![catch {gets stdin line} error]} {
				if [eof stdin] { exit }
				set line_source stdin ; process-line $line
				puts -nonewline stdout $prompt ; flush stdout
			} else {
				if {![string match *I/O* $error]} {
					error $error $errorInfo $errorCode
				}
			}
		}
	}
	# Tcl 8.1 is buggy; it coredumps on large output chunks unless this
	# line is here.  I traced the bug as far as generic/tclIO.c:1795
	# (panic("Blocking channel driver did not block on output")).
	if {!$is_tclet} { fconfigure stdout -blocking true }
}


######################################################################
# Handling for the X buffer and window.
proc x-buffer-init {} {
	both-buffer-init

	global tcl_platform

	# Default options.
	set name [winfo name .]
	option add $name.TabWidth 8 startupFile
	option add $name.WrapLines on startupFile
	option add $name.Scrollbar on startupFile

	switch $tcl_platform(platform) {
		unix {
			option add $name*font fixed startupFile
		}
		windows - macintosh {
			option add $name*font {Courier 10} startupFile
		}
	}

	option add $name.currentBackground DarkGrey   startupFile
	option add $name.subcmdBackground  Plum       startupFile
	option add $name.rangeBackground   SkyBlue    startupFile
	option add $name.destBackground    LightCoral startupFile
	option add $name.insertBackground  LightGreen startupFile

	option add $name.status.errorForeground Red startupFile

	text .t -yscrollcommand ".ysb set" -setgrid 1 -takefocus 0 \
			-width 80 -height 24 \
			-insertwidth 0 -insertborderwidth 0 \
			-bd 1 -relief raised -highlightthickness 0
	set fontw [font measure [option get .t font Font] " "]
	.t configure -tabs [expr $fontw * [option get . tabWidth TabWidth]]
	switch -- [string tolower [option get . wrapLines WrapLines]] {
		1 - true - yes - on            { .t configure -wrap char }
		0 - false - no - off - default { .t configure -wrap none }
	}
	scrollbar .ysb -command ".t yview" -takefocus 0 \
			-bd 1 -relief raised -highlightthickness 0
	entry .e -textvariable entry_line \
			-bd 1 -relief sunken -highlightthickness 0
	label .status -textvariable status_line -anchor w -justify left \
			-width 1 -bd 1 -relief raised

	# Default options derived from cget defaults.
	option add $name.status.errorBackground [.status cget -bg] startupFile
	option add $name.status.foreground      [.status cget -fg] startupFile
	option add $name.status.background      [.status cget -bg] startupFile

	global old_status_width
	set old_status_width [winfo width .status]
	bind .status <Configure> {
		set width [winfo width .status]
		if {$width != $old_status_width} {
			.status configure -wraplength $width
			set old_status_width $width
		}
	}

	.t tag configure current \
		-foreground [option get . currentForeground Foreground] \
		-background [option get . currentBackground Background]
	.t tag configure range \
		-foreground [option get .   rangeForeground Foreground] \
		-background [option get .   rangeBackground Background]
	.t tag configure dest \
		-foreground [option get .    destForeground Foreground] \
		-background [option get .    destBackground Background]
	.t tag configure text \
		-foreground [option get .  insertForeground Foreground] \
		-background [option get .  insertBackground Background]
	bind .t <ButtonPress-1> { set b1_moved 0 ; set x %x ; set y %y }
	bind .t <B1-Motion>     {
		if {abs($x - %x) > 1 || abs($y - %y) > 1} { set b1_moved 1 }
	}
	bind .t <ButtonRelease-1> {
		if !$b1_moved {
			regexp {^([0-9]+)} [.t index @%x,%y] current_addr
		}
	}
	bind .t <ButtonPress-3> {
		regexp {^([0-9]+)} [.t index @%x,%y] pointer_addr1
		read-addr-range $entry_line entry_line trash trash
		set entry_line $pointer_addr1$entry_line
		raise .e ; bind .e <Key> {} ; .e icursor end
	}
	bind .t <B3-Motion> {
		event-delay b3 {
			regexp {^([0-9]+)} [.t index @%x,%y] pointer_addr2
			read-addr-range $entry_line entry_line trash trash
			if {$pointer_addr2 > $pointer_addr1} {
				set entry_line $pointer_addr1,$pointer_addr2$entry_line
			} else {
				set entry_line $pointer_addr2,$pointer_addr1$entry_line
			}
			.e icursor end
			see-addr $pointer_addr2

			# Temporarily disable the see-addr command so that
			# update-textbox-current_addr doesn't override _this_
			# see-addr (see above).  Kludgey, but oh well.
			rename see-addr _see-addr
			proc see-addr {args} {}
			after idle {catch {rename see-addr {} ; rename _see-addr see-addr}}
		}
	}
	bind .t <Shift-ButtonPress-3> {
		regexp {^([0-9]+)} [.t index @%x,%y] pointer_addr1
		regsub {[0-9]*$} $entry_line {} entry_line
		.e icursor end
		append entry_line $pointer_addr1
		raise .e ; bind .e <Key> {}
	}
	bind .t <Shift-B3-Motion> {# nothing}

	bind .t <<Cut>> break
	bind .t <<Paste>> break
	bind .t <<PasteSelection>> break
	bind .t <<Clear>> break

	bind .e <Key-Tab> {
		tkEntryInsert %W \t
		#focus %W
		break
	}

	bind .e <Key> { raise .e ; bind .e <Key> {} }
	bind .e <Key-Return> {
		set line $entry_line ; set entry_line {} ; set line_source X
		process-line $line
	}
	bind .e <Key-Escape> {
		set entry_line {}
		lower .e ; bind .e <Key> { raise .e ; bind .e <Key> {} }
	}

	foreach ignore {
		Shift_L Shift_R Control_L Control_R Meta_L Meta_R Alt_L Alt_R
		Super_L Super_R Hyper_L Hyper_R Caps_Lock Num_Lock
		Up Down Prior Next
	} {
		bind .e <Key-$ignore> continue
	}
	if {$tcl_platform(platform) == "unix"} {
		bind .e <Key-Scroll_Lock> continue
	}

	bind . <Key-Up>    { .t yview scroll -1 unit }
	bind . <Key-Down>  { .t yview scroll  1 unit }
	bind . <Key-Prior> { .t yview scroll -1 page }
	bind . <Key-Next>  { .t yview scroll  1 page }
	bind . <Control-Key-d> { exit }

	wm protocol . WM_DELETE_WINDOW { command-quit {} {} q {} }

	switch -- [string tolower [option get . scrollbar Scrollbar]] {
		1 - true - yes - on {
			grid .t      .ysb -sticky nsew
			grid .status -    -sticky nsew
		}
		0 - false - no - off - default {
			grid .t      -sticky nsew
			grid .status -sticky nsew
		}
	}
	grid    rowconfigure . 0 -weight 1
	grid columnconfigure . 0 -weight 1
	place .e -in .status -relx 0 -rely 0 -relwidth 1 -relheight 1
	lower .e

	# Games with focus...
	rename focus _focus
	proc focus {args} {}
	_focus .e
}

proc x-buffer-get {first last} {
	.t get $first.0 $last.end
}

proc x-buffer-put {line text} {
	.t insert [incr line].0 $text\n
}

proc x-buffer-delete {first last} {
	.t delete $first.0 [incr last].0
}

proc x-buffer-clear {} {
	.t delete 1.0 end
}

proc x-buffer-search-forwards {regexp start stop} {
	if {$stop == {}} {
		set match [.t search -forwards -regexp -- $regexp [expr $start-1].end]
	} else {
		set match [.t search -forwards -regexp -- $regexp [expr $start-1].end \
				[expr $stop+1].0]
	}
	if [regexp {^([0-9]+)} $match addr] {
		return $addr
	} else {
		return ""
	}
}

proc x-buffer-search-backwards {regexp start stop} {
	if {$stop == {}} {
		set match [.t search -backwards -regexp -- $regexp [expr $start+1].0]
	} else {
		set match [.t search -backwards -regexp -- $regexp [expr $start+1].0 \
				[expr $stop-1].end]
	}
	if [regexp {^([0-9]+)} $match addr] {
		return $addr
	} else {
		return ""
	}
}

proc x-buffer-mark-set {c line} {
	.t mark set mark_$c $line.0
	.t mark gravity mark_$c right
}

proc x-buffer-mark-get {c} {
	if [catch { regexp {^([0-9]+)} [.t index mark_$c] result }] {
		return {}
	}
	return $result
}


######################################################################
# Handling for the tty buffer.
proc tty-buffer-init {} {
	both-buffer-init

	tty-buffer-clear
}

proc ttybuf-find-addr {addr} {
	global ttybuf
	while {$addr > $ttybuf(last_accurate_addr2ptr)} {
		set ptr $ttybuf(addr.$ttybuf(last_accurate_addr2ptr))
		set ttybuf(addr.[incr ttybuf(last_accurate_addr2ptr)]) \
				$ttybuf($ptr.next)
	}
	return $ttybuf(addr.$addr)
}
proc ttybuf-find-ptr {ptr} {
	global ttybuf

	set addr $ttybuf($ptr.addr)
	set laptr $ttybuf(last_accurate_ptr2addr)
	if {$ttybuf($ptr.addr) > $ttybuf($laptr.addr)} {
		set addr $ttybuf($laptr.addr)
		while {$laptr != {} && $laptr != $ptr} {
			set ttybuf($ttybuf($laptr.next).addr) [incr addr]
			set ttybuf(last_accurate_ptr2addr) $laptr
			set laptr $ttybuf($laptr.next)
		}
		if {$laptr == {}} {
			set addr {}
		} else {
			set ttybuf(last_accurate_ptr2addr) $laptr
		}
	}
	return $addr
}

proc tty-buffer-get {first last} {
	global ttybuf
	set text {}
	set ptr [ttybuf-find-addr $first]
	for {} {$first <= $last} {incr first} {
		lappend text $ttybuf($ptr.line)
		set ptr $ttybuf($ptr.next)
	}
	return [join $text \n]
}

set ttyptrcount 0
proc tty-buffer-put {addr text} {
	global ttybuf ttyptrcount
	set ptr [ttybuf-find-addr $addr]
	set oldnext $ttybuf($ptr.next)
	set lines [split $text \n]
	if {$lines == {}} { set lines {{}} }
	foreach line $lines {
		set next p[incr ttyptrcount]
		set ttybuf($ptr.next) $next
		set ttybuf($next.line) $line
		set ttybuf($next.addr) [incr addr]
		set ttybuf(addr.$addr) $next
		set ptr $next
	}
	set ttybuf($ptr.next) $oldnext
	set ttybuf(last_accurate_addr2ptr) $addr
	set ttybuf(last_accurate_ptr2addr) $ttybuf(addr.[expr $addr-1])
}

proc tty-buffer-delete {first last} {
	global ttybuf
	set ptr1 [ttybuf-find-addr [incr first -1]]
	set ptr2 [ttybuf-find-addr [incr last]]
	set ttybuf($ptr1.next) $ptr2
	set ttybuf(last_accurate_addr2ptr) $first
	if {$ttybuf($ttybuf(last_accurate_ptr2addr).addr) > $first} {
		set ttybuf(last_accurate_ptr2addr) $ttybuf(addr.$first)
	}
}

proc tty-buffer-clear {} {
	global ttybuf
	array set ttybuf {
		last_accurate_addr2ptr 0 last_accurate_ptr2addr ptr0
		addr.0 ptr0 ptr0.next {} ptr0.addr 0
	}
}

proc tty-buffer-search-forwards {regexp start stop} {
	global ttybuf
	set ptr [ttybuf-find-addr $start]
	if {$stop == {}} {
		set stop $start
		while 1 {
			if [regexp -- $regexp $ttybuf($ptr.line)] {
				return $start
			}
			set ptr $ttybuf($ptr.next)
			if {$ptr != {}} {
				incr start
			} else {
				set ptr $ttybuf(ptr0.next)
				set start 1
			}
			if {$start == $stop} { break }
		}
		return ""
	} else {
		for {} {$start <= $stop} {incr start} {
			if [regexp -- $regexp $ttybuf($ptr.line)] {
				return $start
			}
			set ptr $ttybuf($ptr.next)
		}
		return ""
	}
}

proc tty-buffer-search-backwards {regexp start stop} {
	global ttybuf last_addr
	set ptrs {}
	if {$stop == {}} {
		set stop $start
		while 1 {
			set ptr [ttybuf-find-addr $start]
			if [regexp -- $regexp $ttybuf($ptr.line)] {
				return $start
			}
			if {$start != 1} {
				incr start -1
			} else {
				# OK, this is a cop out.  But I'm lazy.
				set start $last_addr
			}
			if {$start == $stop} { break }
		}
		return ""
	} else {
		set ptr [ttybuf-find-addr $start]
		for {} {$stop <= $start} {incr stop} {
			set ptrs [concat [list $ptr] $ptrs]
			set ptr $ttybuf($ptr.next)
		}
		foreach ptr $ptrs {
			if {[regexp -- $regexp $ttybuf($ptr.line)]} {
				return $start
			}
		}
		return ""
	}
}

proc tty-buffer-mark-set {c addr} {
	global ttybuf
	set ttybuf(mark.$c) [ttybuf-find-addr $addr]
}

proc tty-buffer-mark-get {c} {
	global ttybuf
	if ![info exists ttybuf(mark.$c)] { return {} }
	return [ttybuf-find-ptr $ttybuf(mark.$c)]
}


######################################################################

set this_undo_commands {}
set last_undo_commands {}

proc buffer-init {} {
	global ttymode
	if $ttymode {
		tty-buffer-init
	} else {
		x-buffer-init
	}
}
proc buffer-get {first last} {
	global ttymode
	if $ttymode {
		tty-buffer-get $first $last
	} else {
		x-buffer-get $first $last
	}
}
proc buffer-put {addr text} {
	global ttymode this_undo_commands

	set lines [llength [split $text \n]]
	if {$lines == 0} { set lines 1 }
	set this_undo_commands [concat \
		[list "[expr $addr+1],[expr $addr+$lines] d"] \
		$this_undo_commands]

	if $ttymode {
		tty-buffer-put $addr $text
	} else {
		x-buffer-put $addr $text
	}
}
proc buffer-delete {first last} {
	global ttymode this_undo_commands

	set text_lines [split [buffer-get $first $last] \n]
	if {$text_lines == {}} { set text_lines {{}} }
	set this_undo_commands [concat \
			[list "[expr $first-1] a"] \
			$text_lines \
			[list "."] \
			$this_undo_commands]

	if $ttymode {
		tty-buffer-delete $first $last
	} else {
		x-buffer-delete $first $last
	}
}
proc buffer-clear {} {
	global ttymode last_addr this_undo_commands

	set text_lines [split [buffer-get 1 $last_addr] \n]
	if {$text_lines == {}} { set text_lines {{}} }
	set this_undo_commands [concat \
			[list "0 a"] \
			$text_lines \
			[list "."] \
			$this_undo_commands]

	if $ttymode {
		tty-buffer-clear
	} else {
		x-buffer-clear
	}
}
proc buffer-search-forwards {regexp start {stop {}}} {
	global ttymode
	if $ttymode {
		tty-buffer-search-forwards $regexp $start $stop
	} else {
		x-buffer-search-forwards $regexp $start $stop
	}
}
proc buffer-search-backwards {regexp start {stop {}}} {
	global ttymode
	if $ttymode {
		tty-buffer-search-backwards $regexp $start $stop
	} else {
		x-buffer-search-backwards $regexp $start $stop
	}
}
proc buffer-mark-set {c addr} {
	global ttymode this_undo_commands

	if {[string length $c] == 1} {
		# Don't store temp marks.
		set this_undo_commands [concat \
				[list "[buffer-mark-get $c] k$c"] \
				$this_undo_commands]
	}

	if $ttymode {
		tty-buffer-mark-set $c $addr
	} else {
		x-buffer-mark-set $c $addr
	}
}
proc buffer-mark-get {c} {
	global ttymode
	if $ttymode {
		tty-buffer-mark-get $c
	} else {
		x-buffer-mark-get $c
	}
}


######################################################################
# Output procedures, for spewing information back to the user.
if $ttymode {
	set line_source stdin
} else {
	set line_source X
}
proc puts-response {text} {
	global line_source status_line
	switch $line_source {
		stdin { puts stdout $text }
		X {
			set status_line $text
			.status configure \
				-foreground [option get .status foreground Foreground] \
				-background [option get .status background Background]
			lower .e ; bind .e <Key> { raise .e ; bind .e <Key> {} }
		}
	}
}
proc puts-error {text} {
	global line_source status_line
	switch $line_source {
		stdin { puts stderr $text }
		X {
			set status_line $text
			.status configure \
				-foreground [option get .status errorForeground Foreground] \
				-background [option get .status errorBackground Background]
			lower .e ; bind .e <Key> { raise .e ; bind .e <Key> {} }
		}
	}
}


######################################################################
# Realtime updating of text window.
proc update-textbox-entry_line {name1 name2 op} {
	global input_mode entry_line current_addr default_ranges
	foreach tag {range dest} {
		set tag_ranges [.t tag ranges $tag]
		if {[llength $tag_ranges] != 0} {
			eval ".t tag remove $tag $tag_ranges"
		}
	}
	switch -exact -- [lindex $input_mode 0] {
		command - subcommand {
			set addr1 {} ; set addr2 {} ; set dest_addr {}
			catch {
				read-addr-range $entry_line line addr1 addr2
# 				if {$addr1 == {}} {
# 					read-addr-range \
# 							$default_ranges([string index $entry_line 0]) \
# 							line addr1 addr2
# 				}
				set command [string index $line 0]
				if {$command == "m" || $command == "t"} {
					read-addr-range [string range $line 1 end] line trash dest_addr
				}
			}
			if {$addr1 != {}} {
				.t tag add range $addr1.0 [expr $addr2+1].0
				see-addr $addr2
			}
			if {$dest_addr != {}} {
				.t tag add dest $dest_addr.0 [expr $dest_addr+1].0
				see-addr $dest_addr
			}
		}
		text {
			catch { .t delete text.first text.last } error
			set tag_ranges [.t tag ranges text]
			if {[llength $tag_ranges] != 0} {
				eval ".t tag remove text $tag_ranges"
			}
			if {$entry_line != "."} {
				.t insert [expr $current_addr+1].0 $entry_line\n
				.t tag add text \
						[expr $current_addr+1].0 [expr $current_addr+2].0
				see-addr [expr $current_addr+1]
			}
		}
	}
}
set prev_input_mode {}
proc update-textbox-input_mode {name1 name2 op} {
	global prev_input_mode input_mode current_addr
	switch -glob -- [lindex $prev_input_mode 0]/[lindex $input_mode 0] {
		*/text {
			.t insert [expr $current_addr+1].0 \n
			.t tag add text \
					[expr $current_addr+1].0 [expr $current_addr+2].0
			see-addr [expr $current_addr+1]
		}
		text/* {
			if {[.t tag ranges text] != {}} {
				.t delete text.first text.last
			}
		}
		*/subcommand {
			.t tag configure current \
				-foreground [option get . subcmdForeground Foreground] \
				-background [option get . subcmdBackground Background]
		}
		subcommand/* {
			.t tag configure current \
				-foreground [option get . currentForeground Foreground] \
				-background [option get . currentBackground Background]
		}
	}
	set prev_input_mode $input_mode
}
proc update-textbox-current_addr {name1 name2 op} {
	global current_addr
	see-addr $current_addr
	.t tag remove current 1.0 end
	.t tag add current $current_addr.0 [expr $current_addr+1].0
}
proc update-titlebar-default_filename {name1 name2 op} {
	global default_filename
	if {$default_filename == ""} {
		wm title . "XED"
	} else {
		wm title . "XED: $default_filename"
	}
}
proc see-addr {addr} {
	.t see [expr $addr+2].end
	.t see [expr $addr-2].end
	.t see $addr.end
}
if {!$ttymode} {
	trace variable entry_line w {event-delay el update-textbox-entry_line}
	trace variable input_mode w update-textbox-input_mode
	trace variable current_addr w update-textbox-current_addr
	trace variable default_filename w update-titlebar-default_filename
}


# event-delay:  delay processing of an event until idle time, so that
# the event queue will not get backed up.
proc event-delay {name args} {
	upvar #0 afterid_$name id
	if [info exists id] {
		after cancel $id
	}
	if {[llength $args] == 1} { set args [lindex $args 0] }
	set id [after idle $args]
}
# regexp.tcl
# $Id: regexp.tcl,v 1.2 1999/07/28 07:51:56 chris Exp $
# Regular expression handling...  in Tcl.  *hollow laugh*
#
# NOTE incompatibilities with standard ed:
#  Does not implement the \` , \' , \b , or \B escapes.  Implementing
#  these would be very hard.
#
#
# XED --- an X-enabled implementation of ed, the standard editor.
# Copyright (C) 1999  Chris Laas
# 
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# 
# Chris Laas
# golem@mit.edu
# 22 Pratt Court
# Cohasset, MA 02025 USA


#################################################
# Command-line pattern extraction.

# parse-pattern extracts a regexp pattern from the line.
# linevar starts out as "/re/foo" and ends up as "foo";
# delimvar is set to "/";
# and the return value will be "re".
proc parse-pattern {linevar delimitervar} {
	upvar 1 $linevar line $delimitervar delimiter
	global last_regexp

	# Test if this is empty, in which case, use last regexp.
	if {$line == {}} {
		set delimiter {}
	} else {
		set delimiter [string index $line 0]
	}
	if {$line == {} || [string length $line] == 1
			|| [string index $line 0] == [string index $line 1]} {
		if {![info exists last_regexp]} { error "No previous pattern" }
		set line [string range $line 2 end]
		return $last_regexp
	}

	# Go ahead and parse out the regexp.
	set exp {}
	set delimiter [next-char]
	set exp {}
	set c [next-char]
	while {$c != $delimiter && $c != {}} {
		if {$c == "\["} {
			# Parse a character class.
			set c [next-char]
			if {$c == "^" || $c == "\]"} { set c [next-char] }
			while {$c != "\]"} {
				if {$c == {}} { error "Unbalanced brackets (\[\])" }
				if {$c == "\[" && [string match {[.:=]*} $line]} {
					# A subclass inclusion of the form [:FOO:].
					set d [next-char]
					set p [next-char]
					set c [next-char]
					while {$c != "\]" || $p != $d} {
						set p $c ; set c [next-char]
						if {$c == {}} { error "Unbalanced brackets (\[\])" }
					}
				}
				set c [next-char]
			}
		} elseif {$c == "\\"} {
			# Ignore the backquoted character.
			set c [next-char]
			if {$c == {}} { error "Trailing backslash (\\)" }
		}
		set c [next-char]
	}

	if {$c == $delimiter} {
		set exp [string range $exp 0 [expr [string length $exp]-2]]
	}
	set last_regexp $exp
	return $exp
}
proc next-char {} {
	upvar 1 line line exp exp
	set c [string index $line 0]
	set line [string range $line 1 end]
	set exp $exp$c
	return $c
}

proc parse-subst-template {linevar delimiter} {
	upvar 1 $linevar line
	global input_mode continuation last_subst_template

	if {$line == "%" || [string range $line 0 1] == "%$delimiter"} {
		if {![info exists last_subst_template]} {
			error "No previous substitution template"
		}
		set line [string range $line 2 end]
		return $last_subst_template
	}

	while {[regsub {(^|[^\\])\\$} $line "\\1\n" line]} {
		set input_mode "continuation $input_mode"
		vwait input_mode
		append line $continuation
	}

	set template {}
	while 1 {
		set bsindex [string first "\\" $line]
		set dindex  [string first $delimiter $line]
		if {$bsindex != -1 && $bsindex < $dindex} {
			append template [string range $line 0 [expr $bsindex+1]]
			set line [string range $line [expr $bsindex+2] end]
		} elseif {$dindex != -1} {
			append template [string range $line 0 [expr $dindex-1]]
			set line [string range $line $dindex end]
			break
		} else {
			append template $line
			set line {}
			break
		}
	}
	set last_subst_template $template
	return $template
}


#################################################
# Lower-level interface routines.

# Takes an ed-style regexp and returns a Tcl8.1-style regexp.
proc regexp-compile {re} {
	regsub -all {(.)\\\?} $re {\1\{0,1\}} re
	regsub -all {(.)\\\+} $re {\1\{1,\}} re
	return "(?b)$re"
}



##########################
# Initialization.
buffer-init

if {!$debug} { proc bgerror {message} { puts-error $message } }

if {$init_file != ""} { process-line "E $init_file" }
if {!$is_tclet} { puts -nonewline $prompt }

##########################
# Playback mode.
if $playback {
	while {![eof stdin]} {
		gets stdin entry_line ; raise .e
		while {$entry_line != {}} { vwait entry_line }
	}
	exit 0
}


##########################
# Enter event loop in tty mode.
vwait variable_never_set