# sql.tcl

# The purpose of this program is to implement a GUI frontend for a
# command line sql program sql (like psql of postgresql).

# Commands to sql are typed in the upper text widget. When pressing
# Run, the command is transferred to sql via a command pipe. This pipe
# is opened in the method connect_sql of the $::dbObject and creates
# a channel psqlChan. Wirting to this pipe sends input to the sql
# command line tool (e.g. psql in the case of postgresql). The
# stdout and stderr from this pipe are redirected to channels outChan
# and errChan respectively.

# The are based on a simple script "cat.tcl" wich mimics
# the UNIX cat utility: it prints everything it reads on stdin to
# stdout. Each channel runs in a separate instance of the tcl interpreter.
# They are setup in the methods openOutChannel and openErrChannel of
# the Sql objects.

# The following procedures in the global namespace read the channels
# outChan and errChan, and display everyting that is received on a
# txtWidget. The errChan writes with tag "redTag". These procedures
# are bound to the "channel readable event".

# Before deleting this object, first call the destroyWindow method.
# Otherwise, the window and the psql connection become orphans.


class Sql {
	public variable window
	protected variable windowTag
	protected variable txtSQL
	protected variable txtResult
	protected variable wrapOutput
	protected variable parent
	protected variable dbname
	protected variable errChan
	protected variable outChan
	protected variable sqlChan
	protected variable history
	protected variable top
	protected variable cursor
	protected variable btn

	constructor {c_parent} {
		set parent $c_parent
		set dbname [$::dbObject cget -dbname]
		initHistory
		setupWindow
		connectSql
		return
	}

	destructor {
		return
	}

	public method showWindow {} {
		if {$window ne {}} then {
			wm deiconify $window
			raise $window
			focus $window
		} else {
			setupWindow
			connectSql
		}
		return
	}

	public method destroyWindow {} {
		destroy $window
		return
	}

	public method onDestroyWindow {} {
		set window {}
		disconnectSql
		return
	}

	public method processOutChan {} {
		if {![chan eof $outChan]} then {
			$txtResult insert end "[chan gets $outChan]\n"
			$txtResult see end
		} else {
			chan event $outChan readable {}
		}
		return
	}

	public method processErrChan {} {
		if {![chan eof $errChan]} then {
			$txtResult insert end "[chan gets $errChan]\n" {redTag}
			$txtResult see end
		} else {
			chan event $errChan readable {}
		}
		return
	}
	public method onClear {} {
		$txtSQL delete 1.0 end
		set history($top) {}
		set cursor $top
		if {$top > 0} then {
			$btn(Prev) state {!disabled}
		} else {
			$btn(Prev) state {disabled}
		}
		$btn(Next) state {disabled}
		return
	}

	public method onPrev {} {
		if {$cursor == $top} then {
			set history($top) [$txtSQL get 1.0 "end - 1 chars"]
		}
		if {$cursor > 0} then {
			incr cursor -1
			$txtSQL delete 1.0 end
			$txtSQL insert end $history($cursor)
			$btn(Next) state {!disabled}
			if {$cursor == 0} then {
				$btn(Prev) state {disabled}
			}
		} else {
			bell
		}
		return
	}

	public method onNext {} {
		if {$cursor < $top} then {
			incr cursor
			$txtSQL delete 1.0 end
			$txtSQL insert end $history($cursor)
			if {$cursor == $top} then {
				$btn(Next) state {disabled}
			}
			$btn(Prev) state {!disabled}
		} else {
			bell
		}
		return
	}

	public method onReturn {} {
		if {([$txtSQL get "end - 3 chars"] eq {;}) || \
			([$txtSQL get 1.0] eq "\\")} then {
			onRun
		}
		return
	}

	public method onRun {} {
		set cmd [string trim [$txtSQL get 1.0 end]]
		storeCommand $cmd
		chan puts $sqlChan $cmd
		chan flush $sqlChan
		$txtSQL delete 1.0 end
		if {$cmd eq [$::dbObject getSpecialCommand quit]} then {
			destroy $window
		}
		return
	}

	public method connectSql {} {
		set errChan [openErrChannel]
		set outChan [openOutChannel]
		set status [$::dbObject connect_sql $errChan $outChan sqlChan]
		return $status
	}

	public method disconnectSql {} {
		chan close $sqlChan
		chan close $outChan
		chan close $errChan
		return
	}

	public method wrapChanged {} {
		$txtResult configure -wrap $wrapOutput
		return
	}

	public method executeScript {filename encoding} {
		set convertedFile [convertToUTF-8 $filename $encoding $window]
		$txtSQL delete 1.0 end
		set cmd [$::dbObject getSpecialCommand importFile]
		$txtSQL insert end "$cmd '${convertedFile}'"
		onRun
		return
	}

	public method onListDatabases {} {
		set cmd [$::dbObject getSpecialCommand listDatabases]
		$txtSQL delete 1.0 end
		$txtSQL insert end $cmd
		onRun
		return
	}

	public method onListTables {} {
		set cmd [$::dbObject getSpecialCommand listTables]
		$txtSQL delete 1.0 end
		$txtSQL insert end $cmd
		onRun
		return
	}

	public method onImport {} {
		set initialDir [file normalize ~]
		set fromEncoding [encoding system]
		set fileTypes {
			{{SQL statements} {.sql} }
			{{All files} *}
		}
		set defaultExt ".sql"
		set fileName [tk_getOpenFile -title [mc sqlGetImportFile] \
			-filetypes $fileTypes \
			-defaultextension $defaultExt -parent $window \
			-initialdir $initialDir]
		if {$fileName ne {}} then {
			set dlg [ImportDlg "#auto" $window]
			if {[$dlg wait fromEncoding importType]} then {
				switch -- $importType {
					direct {
						if {[catch {open $fileName r} inFile]} then {
							pfm_message $inFile $window
						} else {
							chan configure $inFile -encoding $fromEncoding
							$txtSQL delete 1.0 end
							$txtSQL insert end [chan read -nonewline $inFile]
							chan close $inFile
						}
					}
					execute {
						executeScript $fileName $fromEncoding
					}
				}
			}
		}
		return
	}

	public method onSaveSQL {} {
		set fileTypes {
			{{SQL statements} {.sql} }
			{{All files} *}
		}
		set defaultExt ".sql"
		set filename [tk_getSaveFile -title [mc sqlSelectSaveSQL] \
			-filetypes $fileTypes \
			-defaultextension $defaultExt -parent $window \
			-initialdir [file normalize ~]]
		if {$filename ne {}} then {
			if {[catch {open $filename w} saveChan]} then {
				pfm_message $saveChan $window
			} else {
				chan puts $saveChan [$txtSQL get 1.0 end]
				chan close $saveChan
			}
		}
		return
	}

	public method onSaveOutput {} {
		saveTxtFromWidget $txtResult $window
		return
	}

	public method onClearOutput {} {
		$txtResult delete 1.0 end
		$txtResult yview 0
		return
	}

	public method onPrintOutput {} {
		printTextWidget $txtResult $window
		return
	}

	public method onHelpSql {} {
		set cmd [$::dbObject getSpecialCommand helpSQL]
		$txtSQL delete 1.0 end
		$txtSQL insert end $cmd
		onRun
		return
	}

	public method onHelpSqlCommand {} {
		set cmd "--[mc sqlTypeCmd]\n[$::dbObject getSpecialCommand helpSQL] "
		$txtSQL delete 1.0 end
		$txtSQL insert end $cmd
		return
	}

	public method onHelpSpecial {} {
		set cmd [$::dbObject getSpecialCommand helpTool]
		$txtSQL delete 1.0 end
		$txtSQL insert end $cmd
		onRun
		return
	}

	protected method setupWindow {} {
		set window [toplevel [appendToPath $parent [namespace tail $this]]]
		lappend windowList $window
		wm title $window [mc sqlTitle $dbname]
		wm geometry $window [join $::geometry::sql {x}]
		setupMenus
		set pw [ttk::panedwindow $window.pw -orient vertical]
		set frm1 [ttk::labelframe $pw.frm1 -text [mc sqlStatement] \
			-labelanchor n]
		set txtSQL [text $frm1.txt -wrap word -width 1 -height 1]
		set vsbSQL [ttk::scrollbar $frm1.vsb -orient vertical \
			-command [list $txtSQL yview]]
		$txtSQL configure -yscrollcommand [list $vsbSQL set]
		grid $txtSQL -column 0 -row 0 -sticky wens
		grid $vsbSQL -column 1 -row 0 -sticky ns
		grid columnconfigure $frm1 0 -weight 1
		grid rowconfigure $frm1 0 -weight 1
		set frmButtons [ttk::frame $frm1.btns]
		foreach name {Run Next Prev Clear} {
			set btn($name) [defineButton $frmButtons.btn$name $window btn$name \
				[list $this on$name]]
			pack $btn($name) -side right
		}
		bind $window <Control-KeyPress-Up> \
			[list $btn(Prev) instate {!disabled} [list $btn(Prev) invoke]]
		bind $window <Control-KeyPress-Down> \
			[list $btn(Next) instate {!disabled} [list $btn(Next) invoke]]
		if {$cursor < $top} then {
			$btn(Next) state {!disabled}
		} else {
			$btn(Next) state {disabled}
		}
		if {$cursor > 0} then {
			$btn(Prev) state {!disabled}
		} else {
			$btn(Prev) state {disabled}
		}
		grid $frmButtons -column 0 -columnspan 2 -row 1 -sticky we \
			-pady {10 10} -padx {10 10}
		$pw add $frm1 -weight 2
		set frm2 [ttk::labelframe $pw.frm2 -text [mc sqlOutput] \
			-labelanchor n]
		set txtResult [text $frm2.txt -wrap none -width 1 -height 1 \
			-takefocus 0]
		set vsbResult [ttk::scrollbar $frm2.vsb -orient vertical \
			-command [list $txtResult yview]]
		set hsbResult [ttk::scrollbar $frm2.hsb -orient horizontal \
			-command [list $txtResult xview]]
		$txtResult configure \
			-xscrollcommand [list $hsbResult set] \
			-yscrollcommand [list $vsbResult set]
		$txtResult tag configure redTag -foreground {red3}
		set btnWrap [defineCheckbutton $frm2.btnWrap $window \
			btnWrap [list $this wrapChanged] [scope wrapOutput] \
			word none]
		grid $txtResult -column 0 -row 0 -sticky wens
		grid $vsbResult -column 1 -row 0 -sticky ns
		grid $hsbResult -column 0 -row 1 -sticky we
		grid $btnWrap -column 0 -row 2 -sticky w
		grid columnconfigure $frm2 0 -weight 1
		grid rowconfigure $frm2 0 -weight 1
		$pw add $frm2 -weight 3
		pack $pw -side top -expand 1 -fill both
		pack [ttk::sizegrip ${window}.sg] -side top -anchor e
		set tpOnly [bindToplevelOnly $window <Destroy> \
			[list $this onDestroyWindow]]
		bind $tpOnly <Configure> {set ::geometry::sql {%w %h}}
		bind $window <KeyPress-Escape> [list destroy $window]
		focus $txtSQL
		bind $txtSQL <KeyPress-Return> [list after idle [list $this onReturn]]
		return
	}

	protected method setupMenus {} {
		set menubar [menu ${window}.mb -tearoff 0]
		# Menu SQL
		set mnuSql [menu ${menubar}.sql -tearoff 0]
		addMenuItem $mnuSql sqlMnuDatabases command [list $this onListDatabases]
		addMenuItem $mnuSql sqlMnuImport command [list $this onImport]
		addMenuItem $mnuSql sqlMnuListTables command [list $this onListTables]
		addMenuItem $mnuSql sqlMnuSaveToFile command [list $this onSaveSQL]
		$mnuSql add separator
		addMenuItem $mnuSql sqlMnuClose command [list destroy $window]
		# Menu Output
		set mnuOutput [menu ${menubar}.output -tearoff 0]
		addMenuItem $mnuOutput sqlMnuOutputSave command [list $this onSaveOutput]
		addMenuItem $mnuOutput sqlMnuOutputPrint command [list $this onPrintOutput]
		addMenuItem $mnuOutput sqlMnuOutputClear command [list $this onClearOutput]
		# Menu Help
		set mnuHelp [menu ${menubar}.help -tearoff 0]
		addMenuItem $mnuHelp sqlMnuHelpSQL command [list $this onHelpSql]
		addMenuItem $mnuHelp sqlMnuHelpSpecial command [list $this onHelpSpecial]
		addMenuItem $mnuHelp sqlMnuHelpSQLcommand command [list $this onHelpSqlCommand]
		# Add alle menus to menubar
		addMenuItem $menubar sqlMnuSql cascade $mnuSql
		addMenuItem $menubar sqlMnuOutput cascade $mnuOutput
		addMenuItem $menubar sqlMnuHelp cascade $mnuHelp
		$window configure -menu $menubar
		return
	}

	protected method openErrChannel {} {
		global tcl_platform
		set cat [file join $::config::installDir cat.tcl]
		if {$tcl_platform(platform) eq {windows}} then {
			set tclshell [file join $::config::installDir tclkitsh.exe]
		} else {
			set tclshell [info nameofexecutable]
		}
		set errChan [open [list | $tclshell $cat] RDWR]
		chan configure $errChan -encoding utf-8 -buffering line
		chan event $errChan readable [list $this processErrChan]
		return $errChan
	}

   protected method openOutChannel {} {
		global tcl_platform
		set cat [file join $::config::installDir cat.tcl]
		if {$tcl_platform(platform) eq {windows}} then {
			set tclshell [file join $::config::installDir tclkitsh.exe]
		} else {
			set tclshell [info nameofexecutable]
		}
		set outChan [open [list | $tclshell $cat] RDWR]
		chan configure $outChan -encoding utf-8 -buffering line
		chan event $outChan readable [list $this processOutChan]
		return $outChan
	}

	protected method initHistory {} {
		set top 0
		set cursor 0
		set history(0) {}
		return
	}

	protected method storeCommand {cmd} {
		if {[string range $cmd 0 1] ne \
				[$::dbObject getSpecialCommand importFile]} then {
			set history($top) $cmd
			incr top
			set history($top) {}
			set cursor $top
			$btn(Prev) state {!disabled}
			$btn(Next) state {disabled}
		}
		return
	}

}

class ImportDlg {
	protected variable window
	protected variable charEncoding
	protected variable importType
	protected variable pressedOK 0

	constructor {parent} {
		set charEncoding [encoding system]
		set importType execute
		setupWindow $parent
		return
	}

	destructor {

		return
	}

	public method wait {fromEncodingName importTypeName} {
		upvar $fromEncodingName charEncodingToReturn
		upvar $importTypeName importTypeToReturn
		tkwait window $window
		set charEencodingToReturn $charEncoding
		set importTypeToReturn $importType
		after idle [list delete object $this]
		return $pressedOK
	}

	public method onOK {} {
		set pressedOK 1
		destroy $window
		return
	}

	protected method setupWindow {parent} {
		set window [toplevel ${parent}.import]
		wm title $window [mc sqlImportTitle]
		wm transient $window $parent
		set lbHelpEncoding [ttk::label ${window}.lb1 \
			-text [mc sqlHelpEncoding] -padding {10 10 10 10}]
		set lbCharEncoding [ttk::label ${window}.lb2 \
			-text [mc sqlCharEncoding]]
		set cmbEncoding [ttk::combobox ${window}.cmbenc \
			-textvariable [scope charEncoding] \
			-values [encoding names]]
		set cmd [$::dbObject getSpecialCommand importFile]
		set lbHelpType [ttk::label ${window}.lb3 \
			-text [mc sqlHelpImportType $cmd] -padding {10 10 10 10}]
		set rbExecute [defineRadiobutton ${window}.rb0 $window \
			[mc sqlRbExecute $cmd] {} [scope importType] execute]
		set rbImport [defineRadiobutton ${window}.rb1 $window \
			[mc sqlRbImport] {} [scope importType] direct]
		set frmBtns [ttk::frame ${window}.frmbtns]
		set btnOK [defineButton ${frmBtns}.btnOK $window btnOK \
			[list $this onOK]]
		set btnCancel [defineButton ${frmBtns}.btnCancel $window btnCancel \
			[list destroy $window]]
		grid $lbHelpEncoding -column 0 -row 0 -columnspan 2
		grid $lbCharEncoding -column 0 -row 1
		grid $cmbEncoding -column 1 -row 1
		grid $lbHelpType -column 0 -row 2 -columnspan 2
		grid $rbExecute -column 0 -columnspan 2 -row 3 -sticky w -padx 10
		grid $rbImport -column 0 -columnspan 2 -row 4 -sticky w -padx 10
		pack $btnCancel -side right
		pack $btnOK -side right
		grid $frmBtns -column 1 -row 5 -sticky e
		return
	}
}