#!/usr/bin/wish

# tkregexp 1.0 Beta 3
# By: John Gotts <jgotts@engin.umich.edu>

# A regular expression builder, implemented in Tcl/Tk 8.0.

# Licensed under the GNU GPL.  See <URL:http://www.gnu.org/pub/gnu/COPYING> for
# more info.

# Revision history:
# 07/04/98 - Inauspicious beginnings.
# 07/20/98 - Code cleanup.
# 08/22/98 - More cleanups.  Added scrollbars.

# TODO: Add a short document defining regular expressions.
#       Could we also add support for advanced Perl regular expressions?
#       (Support for these is being added to Tcl/Tk 8.1).

set tkregexp(title) "tkregexp 1.0 Beta 3"
set tk_strictMotif 1

# Find button callback procedure.
proc findbutton_cb { regexp } {

	global tkregexp
	# Make sure we don't have a tag.
	if { [string compare [.text tag names] sel] != 0} then {
		.text tag configure tag1 -foreground $tkregexp(foreground) -background $tkregexp(background)
		.text tag delete tag1
	}
	if { [string length $regexp] > 0 } then {
		set index [.text search -regexp -count length -- $regexp 1.0]
		if { [string length $index] > 0} then {
			.text see $index
			.text tag add tag1 $index "$index + $length chars"
			.text tag configure tag1 -foreground $tkregexp(background) -background $tkregexp(foreground)
		} else {
			tk_messageBox -title "Not Found" -icon error -message "Regular expression not found." -type ok -parent .
		}
	}
}

# Find next button callback procedure.
# Bug: If the user enters a new regexp and hits find again it will start
# searching from the last location.
proc findnextbutton_cb { regexp } {

	global tkregexp
	# If we don't have a tag, act like find.
	if { [string compare [.text tag names] sel] == 0} then {
		findbutton_cb $regexp
		return
	}
	if { [string length $regexp] > 0 } then {
		set index [.text search -regexp -count length -- $regexp tag1.last]
		if { [string length $index] > 0} then {
			.text tag configure tag1 -foreground $tkregexp(foreground) -background $tkregexp(background)
			.text tag delete tag1
			.text see $index
			.text tag add tag1 $index "$index + $length chars"
			.text tag configure tag1 -foreground $tkregexp(background) -background $tkregexp(foreground)
		} else {
			tk_messageBox -title "Not Found" -icon error -message "Regular expression not found." -type ok -parent .
		}
	}
}

# File menu callback procedure.
proc filemenu_cb { menuitem } {

	if { [string compare $menuitem open] == 0 } then {
		set filename [tk_getOpenFile -title "Open test file..." -parent .]
		if { [string length $filename] == 0 } then {
			return
		}
		.text delete 1.0 end
		set filehandle [open $filename r]
		while { ! [eof $filehandle] } {
			.text configure -state normal
			.text insert end [read $filehandle]
			.text configure -state disabled
		}
		close $filehandle
	} elseif { [string compare $menuitem exit] == 0 } then {
		exit
	}
}

# Help menu callback procedure.
proc helpmenu_cb { menuitem } {

	global tkregexp
	if { [string compare $menuitem help] == 0 } then {
		tk_messageBox -title "Help" -icon info -message "For now, this is little more than a glorified search application.  But eventually it will be a general purpose regular expression construction factory." -type ok -parent .
	} elseif { [string compare $menuitem about] == 0 } then {
		tk_messageBox -title "About tkregexp" -icon info -message "$tkregexp(title) by John Gotts <jgotts@engin.umich.edu>." -type ok -parent .
	}
}

proc tkregexp { } {

	# Initialize...
	global tkregexp
	wm title . $tkregexp(title)
	set tkregexp(index) 0

	# Set up the menubar.
	menu .menubar
	. configure -menu .menubar

	menu .menubar.file
	.menubar add cas -lab "File" -und 0 -acc f -menu .menubar.file
	.menubar.file add com -lab "Open..." -und 0 -acc o -com "filemenu_cb open"
	.menubar.file add sep
	.menubar.file add com -lab "Exit" -und 0 -acc e -com "filemenu_cb exit"

	menu .menubar.help
	.menubar add cas -lab "Help" -und 0 -acc h -menu .menubar.help
	.menubar.help add com -lab "Help" -und 0 -acc h -com "helpmenu_cb help"
	.menubar.help add sep
	.menubar.help add com -lab "About" -und 0 -acc a -com "helpmenu_cb about"

	# Set up the rest of the user interface.
	frame .options
	label .options.label -text "Regular Expression"
	entry .options.regexp -width 25 -relief sunken -textvariable regexp
	bind .options.regexp <Return> {findbutton_cb $regexp}
	button .options.find -text "Find" -command {findbutton_cb $regexp}
	button .options.findagain -text "Find Next" -command {findnextbutton_cb $regexp}

	text .text -width 80 -state disabled -wrap none -xscrollcommand ".hscroll set" -yscrollcommand ".vscroll set"
	scrollbar .hscroll -orient horiz -command ".text xview"
	scrollbar .vscroll -orient vertical -command ".text yview"
	set tkregexp(foreground) [.text cget -foreground]
	set tkregexp(background) [.text cget -background]

	pack .options.label .options.regexp .options.find .options.findagain -side left -padx 1m -pady 3m
	pack .options
	pack .hscroll -side bottom -fill x
	pack .vscroll -side right -fill y
	pack .text -side top -expand yes -fill both
}

tkregexp