#!/bin/sh
# run wish \
exec wish8.0 $0 "$@"

#############################################################################
# Visual Tcl v1.11p1 Project
#

#################################
# GLOBAL VARIABLES
#
global awk;
global debug;
global no_global_query_symbol;
global ps;
global ps_all_arg;
global ps_args;
global ps_cmd_col;
global ps_heading;
global ps_heading_split;
global ps_pid_arg;
global ps_pid_param;
global ps_user;
global ps_user_arg;
global ps_user_end;
global refresh_interval;
global show_all;
global sort_order;
global sort_param;
global sort_type;
global widget;

#################################
# USER DEFINED PROCEDURES
#
proc init {argc argv} {

}

init $argc $argv


proc {about} {} {
tk_messageBox -type ok -message "pgmonitor - PostgreSQL session monitor
Version 0.37

ftp://candle.pha.pa.us/pub/postgresql/pgmonitor.tcl

Right-click on an item for help.";
}

proc {adjust_refresh_setting} {click_direction} {
global refresh_interval;

	if {$refresh_interval >= 1 || $click_direction < 1} {
		set refresh_interval [expr $refresh_interval - $click_direction]
	}
	list after 500 show_backends .top
}

proc {save_options} {} {
global debug;
global env;
global refresh_interval;
global sort_order;
global sort_param;
global sort_type;

	# load defaults from user's home directory .pgmonitor file
	if {![catch {open "$env(HOME)/.pgmonitor" w} options_fid]} {
		puts $options_fid 1			;# config file version
		puts $options_fid $refresh_interval
		puts $options_fid $sort_param
		puts $options_fid $sort_order
		puts $options_fid $sort_type
		close $options_fid
		if {$debug} {puts stdout "Options saved"}
	} else {
		if {$debug} {puts stdout "Option save failed:  $options_fid"}
	}
}

proc {show_sort_buttons} {} {
global ps_heading_split;
global sort_param;

	set i 0
	foreach col $ps_heading_split {
		radiobutton .sort_options.column.col_$i  -background #ecf0a4 -highlightthickness 0  -text $col -value $i -variable sort_param
		pack .sort_options.column.col_$i  -in .sort_options.column  -anchor w -expand 0 -fill none  -side top
		incr i
	}
}

proc {show_sort_options} {popup} {
if [winfo exists $popup] {
		wm deiconify $popup
	} else {
		Window show $popup
		show_sort_buttons
	}
}

proc {send_signal} {base signal} {
global debug;
global ps;
global ps_pid_param;

	# find selected process id
	if {[catch {set cur_selection [$base.listboxscroll.border.list get [$base.listboxscroll.border.list curselection]]}]} {
		tk_messageBox -type ok -message "No process selected."
		return
	}
	regsub -all "   *" [string trim $cur_selection] " " selection_pid
	set selection_pid [lindex [split $selection_pid " "] $ps_pid_param]
	if {$debug} {puts stdout "Selected PID:  $selection_pid"}

	# send the signal
	if {[catch {exec kill -$signal $selection_pid} err]} {
		if {[string match "*permit*" $err]} {
			tk_messageBox -type ok -message "No permission."
			return
		} elseif {[string match "*No such process*" $err]} {
			tk_messageBox -type ok -message "Process no longer exists."
			return
		} else {
			tk_messageBox -type ok -message $err
			return
		}
	}
	# update display promptly
	list after 500 show_backends $base
}

proc {show_backends} {base} {
global awk;
global debug;
global ps;
global ps_args;
global ps_cmd_col;
global ps_pid_param;
global ps_pre_cmd_params;
global ps_user;
global ps_user_arg;
global ps_user_end;
global refresh_id;
global refresh_interval;
global show_all;
global sort_order;
global sort_param;
global sort_type;

	set ps_out ""

	if {$debug} {
		puts stdout "\nps output before awk/sort/cut is:  \n"
		puts stdout [exec $ps $ps_args$ps_user_arg $ps_user | cut -c$ps_user_end-255 | sed -n "2,\$p"]
	}

	# ps, remove user column, non-backend lines, and sort
	if [catch {set ps_out [split [exec $ps $ps_args$ps_user_arg $ps_user |	cut -c$ps_user_end-255 |  sed -n "2,\$p" |  $awk "
	{
		cmd=substr(\$0,$ps_cmd_col);		# get just pgsql-generated status part of line
		gsub(\"\\\\(\[^\\\\)\]*\\\\)\",\"\",cmd); # remove entries around parens, (), *BSD
		gsub(\"^\[^:\]*:\",\"\",cmd);		# remove command with colon, cmd:, Linux
		split(cmd,cmd_split);			# split up db-supplied info
		# <7.1 had bug where fields were swapped on some platforms, correct them
		if (cmd_split\[2\] ~ /^\[0-9\]\[0-9\]*\\.\[0-9\]\[0-9\]*\\.\[0-9\]|^\\\[local\\\]\$|^localhost\$/)
		{
			tmp = cmd_split\[2\];
			cmd_split\[2\] = cmd_split\[3\];
			cmd_split\[3\] = tmp;
		}
		# we try to find only backend processes based on the pgsql status display format;
		# must have at least four params and connect info that is IP address or local
		# localhost in 7.0.X, \[local\] in >=7.1
		if ($show_all ||
		    (cmd_split\[4\] != \"\" &&
		     cmd_split\[3\] ~ /^\[0-9\]\[0-9\]*\\.\[0-9\]\[0-9\]*\\.\[0-9\]|^\\\[local\\\]\$|^localhost\$/))
		{
			# prefix line with sorted field
			if ($sort_param < $ps_pre_cmd_params)
				printf \"%s^\", \$[expr $sort_param + 1];
			else	printf \"%s^\", cmd_split\[[expr $sort_param + 1 - $ps_pre_cmd_params]\];

			# print full process detail line in padded format
			printf \"%s %-10.10s%-10.10s%-17s %-s %-s %-s\\n\",
				substr(\$0,1,[expr $ps_cmd_col - 1]),
				cmd_split\[1\],cmd_split\[2\],cmd_split\[3\],
				cmd_split\[4\],cmd_split\[5\],cmd_split\[6\];
		}
		# sort by sorted column, then strip it off
	}" | sort -t "^" -$sort_order$sort_type | cut -d "^" -f2 ] "\n" ]} err] {
		error "ps failed:  $err"
	}

	# get pid of current selection
	set cur_selection ""
	catch {set cur_selection [$base.listboxscroll.border.list get [$base.listboxscroll.border.list curselection]]}
	regsub -all "   *" [string trim $cur_selection] " " selection_pid
	set selection_pid [lindex [split $selection_pid " "] $ps_pid_param]

	#load up the listbox
	$base.listboxscroll.border.list delete 0 [expr [$base.listboxscroll.border.list size] - 1]
	eval {$base.listboxscroll.border.list insert 0} $ps_out

	# restore pid selection
	set i 0
	foreach ps_line $ps_out {
		regsub -all "   *" [string trim $ps_line] " " cur_pid
		set cur_pid [lindex [split $cur_pid " "] $ps_pid_param]
		if {$selection_pid == $cur_pid} {
			$base.listboxscroll.border.list selection set $i
			break
		}
		incr i
	}

	# if we were called by the Refresh button, cancel old timeout
	catch {after cancel $refresh_id}

	# reschedule ourselves
	if {$refresh_interval >= 1} {
		set i [expr $refresh_interval * 1000]
	} else	{
		set i 100
	}
	set refresh_id [after $i show_backends $base]
}

proc {show_query} {base popup} {
global debug;
global no_global_query_symbol;
global ps;
global ps_pid_param;

	# find selected process id
	if {[catch {set cur_selection [$base.listboxscroll.border.list get [$base.listboxscroll.border.list curselection]]}]} {
		tk_messageBox -type ok -message "No process selected."
		return
	}
	regsub -all "   *" [string trim $cur_selection] " " selection_pid
	set selection_pid [lindex [split $selection_pid " "] $ps_pid_param]
	if {$debug} {puts stdout "Selected PID:  $selection_pid"}

	# clear old contents
	$popup.listboxscroll.border.list delete 0 [expr [$popup.listboxscroll.border.list size] - 1]

	# do we have kill() permission.  Easy way to check if we are the proper user.
	if {[catch {exec kill -0 $selection_pid} err]} {
		if {[string match "*permit*" $err]} {
			tk_messageBox -type ok -message "No permission."
			return
		} elseif {[string match "*No such process*" $err]} {
			tk_messageBox -type ok -message "Process no longer exists."
			return
		} else {
			tk_messageBox -type ok -message $err
			return
		}
	}
	if {$debug} {puts stdout "Permission check OK for $selection_pid"}

	# connect via gdb and get query string
	if {$no_global_query_symbol != "Y"} {
		set gdb_out [exec echo "set print elements 0\nprint (char *)debug_query_string\nquit\n" | sh -c "gdb -q -x /dev/stdin postgres $selection_pid 2>&1;exit 0" ]
		if {$debug} {puts stdout "gdb output using global symbol is:  $gdb_out"}
		if {[string match "*No symbol table*" $gdb_out] ||
		    [string match "*no debugging symbols*" $gdb_out]} {
			tk_messageBox -type ok -message "Postgres pre-7.1.1 executables must have a patch applied or be compiled with debug symbols to use this feature."
			return
		}
		if {[string match "*No symbol \"*" $gdb_out]} {
			# we set this now and for later show_query calls
			set no_global_query_symbol "Y"
		}
	}
	if {$no_global_query_symbol == "Y"} {
		set gdb_out [exec echo "set print elements 0\nprint pg_exec_query_string::query_string\nquit\n" | sh -c "gdb -q -x /dev/stdin postgres $selection_pid 2>&1;exit 0" ]
		if {$debug} {puts stdout "gdb output using function paramater is:  $gdb_out"}
	}

	# interpret gdb output
	if {[string match "*\$1 = 0x0*" $gdb_out] ||
	    [string match "*No frame*" $gdb_out]} {
		tk_messageBox -type ok -message "No query being executed."
		return
	} elseif {[string match "* permit*" $gdb_out]} {
		tk_messageBox -type ok -message "No permission."
		return
	} else {
		# success, popup query window
		if [winfo exists $popup] {
			wm deiconify $popup
		} else {
			Window show $popup
		}
		set query [exec echo "$gdb_out" | grep "\\\$1" |  sed "s/^\[^\"\]*\"//" |  sed "s/\"\$//" | sed "s/\\\\n/\\\n/g"]
		eval {$popup.listboxscroll.border.list insert 0} [split $query "\n" ]
	}
}

proc {try_ps_args} {argc argv} {
global awk;
global debug;
global ps;
global ps_all_arg;
global ps_args;
global ps_cmd_col;
global ps_heading;
global ps_pid_arg;
global ps_pid_param;
global ps_user;
global ps_user_arg;
global ps_user_end;

	# This proc either validates the ps_args, ps_all_arg, ps_user_arg,
	# ps_pid_arg values, or throws an error.  If successful, derived
	# information is stored into ps_pid_param and other globals.

	# get USER column parameter number
	set ps_heading_user [split [string trim [exec $ps $ps_args$ps_pid_arg 1 2>/dev/null |  sed -n "1p" |  sed "s/  */ /g" ]] " " ]
	if {$debug} {puts stdout "ps_heading_user:  $ps_heading_user"}
	set ps_user_param -1
	set i 0
	foreach col $ps_heading_user {
		if {[lindex $ps_heading_user $i] == "USER" ||
			[lindex $ps_heading_user $i] == "UID"} {
			set ps_user_param $i
			break
		}
		incr i
	}
	if {$ps_user_param == -1} {
		error "Can't find USER/UID column heading"
	}
	if {$debug} {puts stdout "ps_user_param:  $ps_user_param"}

	# check other columns before we test for postmaster and
	# and process arg columns
	if {![string match "*PID*" $ps_heading_user]} {
		error "Can't find PID column heading"
	}
	if {![string match "*COMMAND*" $ps_heading_user] &&
	    ![string match "*CMD*" $ps_heading_user]} {
		error "Can't find COMMAND/CMD column heading"
	}
	if {$debug} {puts stdout "Found PID and COMMAND/CMD columns"}


	# get end of user column so it can be clipped off
	if {$ps_user_param == 0} {
		set ps_user_end [expr [string length $ps_user] + 1]
	} else {
		set ps_user_end 1
	}
	if {$debug} {puts stdout "ps_user_end:  $ps_user_end"}

	# get PID column parameter number
	set ps_heading_nouser [split [string trim [exec $ps $ps_args$ps_pid_arg 1 | sed -n "1p" | cut -c$ps_user_end-255 | sed "s/  */ /g" ]] " " ]
	if {$debug} {puts stdout "ps_heading_nouser:  $ps_heading_nouser"}
	set ps_pid_param -1
	set i 0
	foreach col $ps_heading_nouser {
		if {[lindex $ps_heading_nouser $i] == "PID"} {
			set ps_pid_param $i
			break
		}
		incr i
	}
	if {$ps_pid_param == -1} {
		puts stderr "Can't find PID column heading"
		exit 1
	}
	if {$debug} {puts stdout "ps_pid_param:  $ps_pid_param"}

	# get a new heading without the user column
	set ps_heading [exec $ps $ps_args$ps_user_arg $ps_user | sed -n "1p" | cut -c$ps_user_end-255]
	if {$debug} {puts stdout "ps_heading:  $ps_heading"}

	# find the column of the COMMAND/CMD
	if {[string first "COMMAND" $ps_heading] != -1} {
		set ps_cmd_col [string first "COMMAND" $ps_heading]
	} elseif {[string first "CMD" $ps_heading] != -1} {
		set ps_cmd_col [string first "CMD" $ps_heading]
	} else {
		puts stderr "Can't find COMMAND/CMD column heading"
		exit 1
	}
	if {$debug} {puts stdout "ps_cmd_col:  $ps_cmd_col"}

	# adjust heading to be the way we want it
	set ps_heading [exec echo "$ps_heading" |  $awk "\{
		printf \"%s %-10.10s%-10.10s%-17s %-s\\n\",
		substr(\$0,1,[expr $ps_cmd_col - 1]),
		\"USER\", \"DATABASE\", \"CONNECTION\", \"QUERY\"
	\}" ]
	if {$debug} {puts stdout "ps_heading:  $ps_heading"}
}

proc {widget_init} {argc argv base} {
global awk;
global debug;
global env;
global no_global_query_symbol;
global ps;
global ps_all_arg;
global ps_args;
global ps_cmd_col;
global ps_heading;
global ps_heading_split;
global ps_pid_arg;
global ps_pid_param;
global ps_pre_cmd_params;
global ps_user;
global ps_user_arg;
global ps_user_end;
global refresh_id;
global refresh_interval;
global show_all;
global sort_order;
global sort_param;
global sort_type;

	# set this to 1 to output debug messages
	set debug 0

	# set this to 1 to show all processes, including postmaster
	set show_all 0

	# set this to customize your ps command
	set ps "ps"

	if {$base == ""} {
		set base .
	}

	# find awk version that supports gsub()
	if {![catch {exec echo | awk "{gsub(\".\",\"\")}"}]} {
		set awk "awk"
	} elseif {![catch {exec echo | nawk "{gsub(\".\",\"\")}"}]} {
		set awk "nawk"
	} elseif {![catch {exec echo | gawk "{gsub(\".\",\"\")}"}]} {
		set awk "gawk"
	} else {
		error "Can't find awk version that supports gsub()"
	}
	if {$debug} {puts stdout "awk version selected:  $awk"}

	# get pg username, either from command line or postmaster process owner
	if {$argc>0} {
		set ps_user [lindex $argv 0]
	# try PGDATA directory ownership
	} elseif {![catch {set ps_user [exec ls -ld "$env(PGDATA)" | $awk "{print \$3}"]}]} {
	# try user name for postmaster from lock file
	} elseif {![catch {set ps_user [exec ls -l "/tmp/.s.PGSQL.5432.lock" | $awk "{print \$3}"]}]} {
	# try user name for postmaster from socket
	} elseif {![catch {set ps_user [exec ls -l "/tmp/.s.PGSQL.5432" | $awk "{print \$3}"]}]} {
	# do expensive full 'ps'
	} else {
		puts stderr "Can't find the username of the PostgreSQL server.\nEither start the postmaster, define PGDATA, or\nsupply the username on the command line."
		exit 1
	}
	if {$debug} {puts stdout "ps_user:  $ps_user"}

	# BSD-style ps arguments mean:
	#	a display other users's processes too
	#	u display user information
	#	w 132 column display
	#	w another 'w' means display as wide as needed, no limit
	set ps_args "auww"
	#	x show processes with no controlling terminal
	set ps_all_arg "x"
	#	U show only certain users processes
	set ps_user_arg "U"
	#	p show pid
	set ps_pid_arg "p"

	if {$debug} {puts stdout "Trying BSD-style ps args"}
	if {[catch {try_ps_args $argc $argv} msg]} {
		if {$debug} {puts stdout "BSD-style ps args failed with:  $msg\nTrying SysV-style"}
		# try SysV-style ps flags:
		#	f display full listing, needs dash
		set ps_args "-f"
		#	e display all processes
		set ps_all_arg "e"
		#	u show only certain users processes
		set ps_user_arg "u"
		#	p show pid
		set ps_pid_arg "p"

		if {[catch {try_ps_args $argc $argv} msg]} {
			if {$debug} {puts stdout "SysV-style ps args failed with:  $msg"}
			error "Can't run 'ps'\nPlease send in a patch."
		}
	}
	if {$debug} {puts stdout "ps command used will be:  $ps $ps_args$ps_user_arg $ps_user"}

	# load the heading
	$base.listboxscroll.border.heading insert 0  $ps_heading
	if {$debug} {puts stdout "ps_heading is:  $ps_heading"}

	# set defaults
	set no_global_query_symbol "N"
	set sort_param "${ps_pid_param}"
	set sort_order ""
	set sort_type "n"

	# load defaults from user's home directory .pgmonitor file
	if {![catch {open "$env(HOME)/.pgmonitor" r} options_fid]} {
		if {![catch {gets $options_fid} pgmonitor_version]} {
			if {$pgmonitor_version == 1} {
				catch {set refresh_interval [gets $options_fid]}
				catch {set sort_param [gets $options_fid]}
				catch {set sort_order [gets $options_fid]}
				catch {set sort_type [gets $options_fid]}
				if {$debug} {puts stdout "Options loaded"}
			} else {
				if {$debug} {puts stdout "Unknown options version"}
			}
		} else {
			if {$debug} {puts stdout "Options gets failed with:  $options_fid"}
		}
		close $options_fid
	} else {
		if {$debug} {puts stdout "Options file open failed with:  $options_fid"}
	}

	# load ps heading values
	regsub -all "   *" [string trim $ps_heading] " " ps_heading_split
	set ps_heading_split [split $ps_heading_split " "]
	set ps_pre_cmd_params [expr [llength $ps_heading_split] - 4]
	if {$debug} {puts stdout "ps_pre_cmd_params:  $ps_pre_cmd_params"}

	# load backends
	show_backends $base

	# keyboard defaults
	bind all <Control-c> {destroy .}
	bind . <Destroy> {save_options; catch {after cancel $refresh_id}}
	bind $base <Destroy> {destroy .}

	focus $base.listboxscroll.border.list

	show_sort_buttons

	wm withdraw .query_popup
	wm withdraw .sort_options
}

proc {main} {argc argv} {
widget_init $argc $argv .top
}

proc {Window} {args} {
global vTcl
    set cmd [lindex $args 0]
    set name [lindex $args 1]
    set newname [lindex $args 2]
    set rest [lrange $args 3 end]
    if {$name == "" || $cmd == ""} {return}
    if {$newname == ""} {
	set newname $name
    }
    set exists [winfo exists $newname]
    switch $cmd {
	show {
	    if {$exists == "1" && $name != "."} {wm deiconify $name; return}
	    if {[info procs vTclWindow(pre)$name] != ""} {
		eval "vTclWindow(pre)$name $newname $rest"
	    }
	    if {[info procs vTclWindow$name] != ""} {
		eval "vTclWindow$name $newname $rest"
	    }
	    if {[info procs vTclWindow(post)$name] != ""} {
		eval "vTclWindow(post)$name $newname $rest"
	    }
	}
	hide	{ if $exists {wm withdraw $newname; return} }
	iconify { if $exists {wm iconify $newname; return} }
	destroy { if $exists {destroy $newname; return} }
    }
}

#################################
# VTCL GENERATED GUI PROCEDURES
#

proc vTclWindow. {base} {
    if {$base == ""} {
	set base .
    }
    ###################
    # CREATING WIDGETS
    ###################
    wm focusmodel $base active
    wm geometry $base 200x200
    wm maxsize $base 1009 738
    wm minsize $base 1 1
    wm overrideredirect $base 0
    wm resizable $base 1 1
    wm withdraw $base
    wm title $base "vt.tcl"
    ###################
    # SETTING GEOMETRY
    ###################
}

proc vTclWindow.query_popup {base} {
    if {$base == ""} {
	set base .query_popup
    }
    if {[winfo exists $base]} {
	wm deiconify $base; return
    }
    ###################
    # CREATING WIDGETS
    ###################
    toplevel $base -class Toplevel \
	-background #c4eeec -borderwidth 2
    wm focusmodel $base passive
    wm geometry $base 647x298
    wm maxsize $base 1009 738
    wm minsize $base 1 1
    wm overrideredirect $base 0
    wm resizable $base 1 1
    wm deiconify $base
    wm title $base "Query String"
    frame $base.listboxscroll \
	-background #c4eeec -highlightbackground #c4eeec
    scrollbar $base.listboxscroll.xscroll \
	-activebackground #ecf0a4 -background #ecf0a4 \
	-command {.query_popup.listboxscroll.border.list xview} \
	-highlightbackground #c4eeec -highlightthickness 0 -orient horizontal \
	-takefocus 0 -troughcolor #c4eeec
    scrollbar $base.listboxscroll.yscroll \
	-activebackground #ecf0a4 -background #ecf0a4 \
	-command {.query_popup.listboxscroll.border.list yview} \
	-highlightbackground #c4eeec -highlightthickness 0 -takefocus 0 \
	-troughcolor #c4eeec
    frame $base.listboxscroll.border \
	-background #ecf0a4 -borderwidth 4 -highlightbackground #c4eeec \
	-relief sunken
    listbox $base.listboxscroll.border.list \
	-background #ecf0a4 -borderwidth 0 -font {Fixed -12 bold} -height 1 \
	-highlightbackground #e8dc4c -highlightthickness 0 -relief flat \
	-selectbackground #dade4a -takefocus 1 -width 1 \
	-xscrollcommand {.query_popup.listboxscroll.xscroll set} \
	-yscrollcommand {.query_popup.listboxscroll.yscroll set}
    button $base.exit \
	-activebackground #fe4020 -activeforeground #ecf0a4 \
	-background #be4020 -command {wm withdraw .query_popup} \
	-foreground #ecf0a4 -padx 9 -pady 3 -takefocus 1 -text Close
    ###################
    # SETTING GEOMETRY
    ###################
    pack $base.listboxscroll \
	-in .query_popup -anchor center -expand 1 -fill both -side top
    pack $base.listboxscroll.xscroll \
	-in .query_popup.listboxscroll -anchor center -expand 0 -fill x \
	-side bottom
    pack $base.listboxscroll.yscroll \
	-in .query_popup.listboxscroll -anchor center -expand 0 -fill y \
	-side right
    pack $base.listboxscroll.border \
	-in .query_popup.listboxscroll -anchor center -expand 1 -fill both \
	-padx 6 -pady 6 -side top
    pack $base.listboxscroll.border.list \
	-in .query_popup.listboxscroll.border -anchor center -expand 1 \
	-fill both -padx 5 -pady 6 -side bottom
    pack $base.exit \
	-in .query_popup -anchor e -expand 0 -fill x -padx 5 -pady 5 \
	-side bottom
}

proc vTclWindow.sort_options {base} {
    if {$base == ""} {
	set base .sort_options
    }
    if {[winfo exists $base]} {
	wm deiconify $base; return
    }
    ###################
    # CREATING WIDGETS
    ###################
    toplevel $base -class Toplevel \
	-background #c4eeec -borderwidth 2
    wm focusmodel $base passive
    wm geometry $base 244x513
    wm maxsize $base 1009 738
    wm minsize $base 1 1
    wm overrideredirect $base 0
    wm resizable $base 1 1
    wm deiconify $base
    wm title $base "Sort Options"
    label $base.sort_column \
	-background #c4eeec -text Column
    frame $base.column \
	-background #ecf0a4 -borderwidth 2 -relief sunken
    label $base.sort_order \
	-background #c4eeec -text Order
    frame $base.order \
	-background #ecf0a4 -borderwidth 2 -relief sunken
    radiobutton $base.order.ascending \
	-background #ecf0a4 -highlightthickness 0 -text Ascending \
	-variable sort_order
    radiobutton $base.order.descending \
	-background #ecf0a4 -highlightthickness 0 -text Descending -value r \
	-variable sort_order
    label $base.sort_type \
	-background #c4eeec -text Type
    frame $base.type \
	-background #ecf0a4 -borderwidth 2 -relief sunken
    radiobutton $base.type.numeric \
	-background #ecf0a4 -highlightthickness 0 -text Numeric -value n \
	-variable sort_type
    radiobutton $base.type.alphabetic \
	-background #ecf0a4 -highlightthickness 0 -text Alphabetic \
	-variable sort_type
    button $base.exit \
	-activebackground #fe4020 -activeforeground #ecf0a4 \
	-background #be4020 -command {wm withdraw .sort_options} \
	-foreground #ecf0a4 -padx 9 -pady 3 -takefocus 1 -text Close
    ###################
    # SETTING GEOMETRY
    ###################
    pack $base.sort_column \
	-in .sort_options -anchor w -expand 1 -fill both -side top
    pack $base.column \
	-in .sort_options -anchor w -expand 1 -fill x -side top
    pack $base.sort_order \
	-in .sort_options -anchor w -expand 1 -fill both -side top
    pack $base.order \
	-in .sort_options -anchor w -expand 1 -fill x -side top
    pack $base.order.ascending \
	-in .sort_options.order -anchor w -expand 0 -fill none -side top
    pack $base.order.descending \
	-in .sort_options.order -anchor w -expand 0 -fill none -side top
    pack $base.sort_type \
	-in .sort_options -anchor w -expand 1 -fill both -side top
    pack $base.type \
	-in .sort_options -anchor w -expand 1 -fill x -side top
    pack $base.type.numeric \
	-in .sort_options.type -anchor w -expand 0 -fill none -side top
    pack $base.type.alphabetic \
	-in .sort_options.type -anchor w -expand 0 -fill none -side top
    pack $base.exit \
	-in .sort_options -anchor e -expand 0 -fill x -padx 5 -pady 5 \
	-side bottom
}

proc vTclWindow.top {base} {
    if {$base == ""} {
	set base .top
    }
    if {[winfo exists $base]} {
	wm deiconify $base; return
    }
    ###################
    # CREATING WIDGETS
    ###################
    toplevel $base -class Toplevel \
	-background #c4eeec -borderwidth 2
    wm focusmodel $base passive
    wm geometry $base 787x513
    wm maxsize $base 1009 738
    wm minsize $base 1 1
    wm overrideredirect $base 0
    wm resizable $base 1 1
    wm deiconify $base
    wm title $base "pgmonitor"
    frame $base.listboxscroll \
	-background #c4eeec -highlightbackground #c4eeec
    scrollbar $base.listboxscroll.xscroll \
	-activebackground #ecf0a4 -background #ecf0a4 \
	-command {.top.listboxscroll.border.list xview} \
	-highlightbackground #c4eeec -highlightthickness 0 -orient horizontal \
	-takefocus 0 -troughcolor #c4eeec
    scrollbar $base.listboxscroll.yscroll \
	-activebackground #ecf0a4 -background #ecf0a4 \
	-command {.top.listboxscroll.border.list yview} \
	-highlightbackground #c4eeec -highlightthickness 0 -takefocus 0 \
	-troughcolor #c4eeec
    frame $base.listboxscroll.border \
	-background #ecf0a4 -borderwidth 4 -highlightbackground #c4eeec \
	-relief sunken
    listbox $base.listboxscroll.border.heading \
	-background #ecf0a4 -font {Fixed -12 bold} -height 1 \
	-highlightbackground #e8dc4c -highlightthickness 0 -relief raised \
	-selectbackground #dade4a -takefocus 0 -width 1 \
	-xscrollcommand {.top.listboxscroll.xscroll set}
    listbox $base.listboxscroll.border.list \
	-background #ecf0a4 -borderwidth 0 -font {Fixed -12 bold} -height 1 \
	-highlightbackground #e8dc4c -highlightthickness 0 -relief flat \
	-selectbackground #dade4a -takefocus 1 -width 1 \
	-xscrollcommand {.top.listboxscroll.xscroll set} \
	-yscrollcommand {.top.listboxscroll.yscroll set}
    bind $base.listboxscroll.border.list <Double-Button-1> {
	show_query .top .query_popup
    }
    bind $base.listboxscroll.border.list <Key-Return> {
	show_query [list $base .query_popup]
    }
    frame $base.button \
	-background #c4eeec
    button $base.button.refresh \
	-activebackground #fe4020 -activeforeground #ecf0a4 \
	-background #be4020 -command {after idle show_backends .top} \
	-foreground #ecf0a4 -padx 9 -pady 3 -takefocus 1 -text Refresh
    bind $base.button.refresh <Button-3> {
	tk_messageBox -type ok -message "Refreshes the process listing."
    }
    scrollbar $base.button.refresh_scroll \
	-background #c4eeec -command {adjust_refresh_setting } -orient vert \
	-width 7
    label $base.button.refresh_setting \
	-anchor e -background #c4eeec -padx 0 -pady 0 -text 21 \
	-textvariable refresh_interval -width 3
    label $base.button.seconds \
	-anchor w -background #c4eeec -padx 0 -pady 3 -text seconds -width 7
    button $base.button.sort \
	-activebackground #fe4020 -activeforeground #ecf0a4 \
	-background #be4020 -command {show_sort_options .sort_options} \
	-foreground #ecf0a4 -padx 9 -pady 3 -takefocus 1 -text Sort
    bind $base.button.sort <Button-3> {
	tk_messageBox -type ok -message "Allows sorting of processes."
    }
    button $base.button.query \
	-activebackground #fe4020 -activeforeground #ecf0a4 \
	-background #be4020 -command {show_query .top .query_popup} \
	-foreground #ecf0a4 -padx 9 -pady 3 -takefocus 1 -text Query
    bind $base.button.query <Button-3> {
	tk_messageBox -type ok -message "Shows query currently executing by a process.\nDouble-clicking on a process does the same thing."
    }
    button $base.button.cancel \
	-activebackground #fe4020 -activeforeground #ecf0a4 \
	-background #be4020 -command {send_signal .top 2} -foreground #ecf0a4 \
	-padx 9 -pady 3 -takefocus 1 -text Cancel
    bind $base.button.cancel <Button-3> {
	tk_messageBox -type ok -message "Cancels the currently running query."
    }
    button $base.button.terminate \
	-activebackground #fe4020 -activeforeground #ecf0a4 \
	-background #be4020 -command {send_signal .top 15} \
	-foreground #ecf0a4 -padx 9 -pady 3 -takefocus 1 -text Terminate
    bind $base.button.terminate <Button-3> {
	tk_messageBox -type ok -message "Terminates the process."
    }
    button $base.button.exit \
	-activebackground #fe4020 -activeforeground #ecf0a4 \
	-background #be4020 -command {destroy .} -foreground #ecf0a4 -padx 9 \
	-pady 3 -takefocus 1 -text Exit
    bind $base.button.exit <Button-3> {
	tk_messageBox -type ok -message "Exits the application."
    }
    button $base.button.about \
	-activebackground #fe4020 -activeforeground #ecf0a4 \
	-background #be4020 -command about -foreground #ecf0a4 -padx 9 \
	-pady 3 -takefocus 1 -text About
    bind $base.button.about <Button-3> {
	tk_messageBox -type ok -message "You want help about 'about'?"
    }
    ###################
    # SETTING GEOMETRY
    ###################
    pack $base.listboxscroll \
	-in .top -anchor center -expand 1 -fill both -side top
    pack $base.listboxscroll.xscroll \
	-in .top.listboxscroll -anchor center -expand 0 -fill x -side bottom
    pack $base.listboxscroll.yscroll \
	-in .top.listboxscroll -anchor center -expand 0 -fill y -side right
    pack $base.listboxscroll.border \
	-in .top.listboxscroll -anchor center -expand 1 -fill both -padx 6 \
	-pady 6 -side top
    pack $base.listboxscroll.border.heading \
	-in .top.listboxscroll.border -anchor center -expand 0 -fill x \
	-padx 5 -pady 6 -side top
    pack $base.listboxscroll.border.list \
	-in .top.listboxscroll.border -anchor center -expand 1 -fill both \
	-padx 5 -pady 6 -side bottom
    pack $base.button \
	-in .top -anchor center -expand 0 -fill x -side bottom
    pack $base.button.refresh \
	-in .top.button -anchor e -expand 0 -fill none -padx 5 -pady 5 \
	-side left
    pack $base.button.refresh_scroll \
	-in .top.button -anchor center -expand 0 -fill none -side left
    pack $base.button.refresh_setting \
	-in .top.button -anchor e -expand 0 -fill none -side left
    pack $base.button.seconds \
	-in .top.button -anchor center -expand 0 -fill none -side left
    pack $base.button.sort \
	-in .top.button -anchor e -expand 0 -fill none -padx 5 -pady 5 \
	-side left
    pack $base.button.query \
	-in .top.button -anchor e -expand 1 -fill none -padx 5 -pady 5 \
	-side left
    pack $base.button.cancel \
	-in .top.button -anchor e -expand 0 -fill none -padx 5 -pady 5 \
	-side left
    pack $base.button.terminate \
	-in .top.button -anchor e -expand 0 -fill none -padx 5 -pady 5 \
	-side left
    pack $base.button.exit \
	-in .top.button -anchor e -expand 0 -fill none -padx 5 -pady 5 \
	-side right
    pack $base.button.about \
	-in .top.button -anchor e -expand 1 -fill none -padx 5 -pady 5 \
	-side right
}

Window show .
Window show .query_popup
Window show .sort_options
Window show .top

main $argc $argv
