#!/usr/local/bin/wish -file

#
# $Id: tkquerypr,v 1.3 1993/11/16 22:19:40 jason Exp $
#

set TkGnats(lib) ./; ##TKGNATSLIB##

#
# ---- Globals
#


# This is after the some of the global defns so that the user can 
# override some of them if they wish in their .tkgnatsrc
foreach f { tkpr_library.t reports.t tkprfolder.t } {
    source $TkGnats(lib)/$f
}
proc Msg {args} {
    eval exec msgDialog [wm title .] "" $args &
    schedule_reap
}


# ID-NUMBER | CATEGORY | SYNOPSIS | CONFIDENTIAL |
# SEVERITY | PRIORITY | RESPONSIBLE | STATE | CLASS |
# SUBMITTER-ID | ARRIVAL-DATE | ORIGINATOR | RELEASE

# used when calling sortDialog
set Query(sort_flds) {
    Number	Category	Synopsis	Confidential 
    Severity	Priority	Responsible	State	Class 
    Submitter-Id Arrival-Date	Originator	Release
}
set Query(sort_flgs) {
    "n"		""		""  		""
    "n"		"n"		""  		"n"	"" 
    ""		""		""		""
}
# fields that are queryable via query-pr
# XXX Note: Originator is indexed but we treate it like it's not
# that way we can use glob style matches
set Query(indexed_fields) {
    Category Submitter Responsible State Confidential 
    Severity Priority 
}

# used when calling sortDialog
set Query(category_pat) "*"
set Query(tmpfile) \
    [format "/tmp/tkquery.%s.[exec date +%d.%H.%M.%S]" $TkGnats(LogName)]

#
# numeric --> textual mappings for some query-pr --sql fields
#
set Mappings(State) {open analyzed suspended feedback closed}
set Mappings(Priority) {high medium low}
set Mappings(Severity) {critical serious non-critical}
set Mappings(Class) {sw-bug doc-bug support change-request mistaken duplicate}


#
# ---- Procedures
#

set Query(default_sort_file) [glob -nocomplain -- ~/TkGnats/default-sort]
proc get_default_sort_criteria {} {
    global Query
    check_tkgnats_userdir
    if {$Query(default_sort_file) != ""} {
	if {[file exists $Query(default_sort_file)]} {
	    set fin [open $Query(default_sort_file) "r"]
	    if {[gets $fin ln] >= 0} {
		if {$ln == ""} {
		    Msg "$Query(default_sort_file) is empty??"
		} else {
		    return $ln
		}
	    } else {
		Msg "$Query(default_sort_file) is empty??"
	    }
	    close $fin
	}
    }
    return "sort -t| -fb +1 -2 +7n -8 +5n -6 +4n -5 +0n -1"
}
set Query(sort_cmd) [get_default_sort_criteria]
proc set_default_sort_criteria {str} {
    global Query
    check_tkgnats_userdir
    exec rm -f $Query(default_sort_file)
    set fout [open $Query(default_sort_file) "w"]
    puts $fout $str
    close $fout
}

proc prid_from_selection {} {
    set s ""
    catch {set s [selection get STRING]}
    set s \
	[lindex [string trim $s "\t\n !@#\$%^&*()_-+=|\\{}\[\]:;'~`<>,.?\""] 0]
    return $s
}

proc query_from_selection {} {
    set s [prid_from_selection]
    if {"$s" == ""} {
	Msg "No PR id available in selection"
	return;
    }
    if {[catch {query_cmd $s} errs]} {
	tkerror "Error querying with selection\n<<<$s>>>\n$errs"
    }
}

set wstate 1
proc workingMsg {} {
    global wstate TkGnats
    case $wstate 1 {
	.mframe.l configure -bitmap @$TkGnats(lib)/working2.xbm
	set wstate 2
    } 2 {
	.mframe.l configure -bitmap @$TkGnats(lib)/working1.xbm
	set wstate 1
    }
    update idletasks
}

proc category_listbox {parent pat} {
    global Category
    # Just a place holder so that Category is defined as an array
    set Category(All) ""

    frame $parent.cat 
    pack append $parent $parent.cat {top fillx pady 8}

    frame $parent.cat.l
    message $parent.cat.l.msg -anchor w -relief sunken \
	-text "Available Categories:" -aspect 10000
    pack append $parent.cat $parent.cat.l {left}

    frame $parent.cat.r
    message $parent.cat.r.msg -anchor w  -relief sunken \
	-text "Selected Categories:" -aspect 10000
    pack append $parent.cat $parent.cat.r {right}

    foreach side {l r} {
	set p $parent.cat.$side
	scrollbar $p.sb -command "$p.list yview" -borderwidth 2 \
	    -relief sunken
	listbox $p.list -yscroll "$p.sb set" -setgrid 1 \
	    -relief sunken -borderwidth 2 \
	    -geometry 15x8
	pack append $p \
	    $p.msg {top fillx} \
	    $p.sb {left filly} \
	    $p.list {right expand fill}
	tk_listboxSingleSelect $p.list
    }

    eval $parent.cat.l.list insert end [get_categories $pat]
    bind $parent.cat.l.list <B1-ButtonRelease> \
	    "category_add_cmd %W %y $parent.cat.r.list"

    bind $parent.cat.r.list <B1-ButtonRelease> \
	    "category_delete_cmd %W %y $parent.cat.l.list"

}

proc list_item_switch_cmd {srcw y destw} {
    set idx [$srcw nearest $y]
    set ln [$srcw get $idx]
    if {"$ln" != ""} {
	$srcw delete $idx
	$destw insert end $ln
    }
    return $ln
}

proc category_add_cmd {srcw y destw} {
    global Category
    set val [list_item_switch_cmd $srcw $y $destw]
    set Category($val) $val
}

proc category_delete_cmd {srcw y destw} {
    global Category
    set val [list_item_switch_cmd $srcw $y $destw]
    if {"$val" != ""} {
	unset Category($val)
    }
}

proc query_listbox {p} {
    global Category ""
    set lboxwidth  100
    frame $p.query 
    pack append $p $p.query {top expand fill}
    scrollbar $p.query.sb -command "$p.query.list yview" -borderwidth 2
    label $p.query.label -font fixed -anchor w -text \
 {    Id  Responsible Category         State    Priority Severity     Synopsis}

    listbox $p.query.list -font fixed -yscroll "$p.query.sb set" -setgrid 1 \
	-relief sunken -borderwidth 2 -geometry ${lboxwidth}x8
    pack append $p.query \
	$p.query.label {top fillx} \
	$p.query.sb {left filly} \
	$p.query.list {right expand fill}
    tk_listboxSingleSelect $p.query.list
    bind $p.query.list <Enter> "+focus %W"
    bind $p.query.list <Double-Button-1> "editSelection_cmd %W"

    bind $p.query.list <Control-l> "%W xview 0"
    bind $p.query.list <KeyRelease-Left> "%W xview 0"

    bind $p.query.list <KeyRelease-Right> "%W xview [expr $lboxwidth/2]"
    bind $p.query.list <Control-r> "%W xview [expr $lboxwidth/2]"

    return $p.query.list
}

#
# ---- Callbacks
#
proc folder_view_cmd {} {
    tkprfolder_dialog .tkprfolder
}

proc pridfromsummaryline {ln} {
    scan $ln "%d" prid
    return $prid
}
proc selln {w} {
    set x  [$w curselection]
    if {[llength $x] == 0} {
	return ""
    } else {
	return [$w get [lindex $x 0]]
    }
}

proc editSelection_cmd {w} {
    global TkGnats
    set ln [selln $w]
    if {"$ln" != ""} {
	headingMsg "Please Wait..."
	set prid [pridfromsummaryline $ln]
	exec sh -c [format $TkGnats(pr_editor) $prid] &
	schedule_reap
	after 2000 {headingMsg " "}
    }
}

proc printSelection_cmd {w} {
    set ln [selln $w]
    if {"$ln" != ""} {
	set prid [pridfromsummaryline $ln]
	fullreport $prid
    }
}

proc viewSelection_cmd {w} {
    global Query
    set ln [selln $w]
    if {"$ln" != ""} {
	set prid [pridfromsummaryline $ln]
	exec tkviewpr $prid &
	schedule_reap
    }
}

proc previewPrintSelection_cmd {w} {
    global Query TkGnats
    set ln [selln $w]
    if {"$ln" != ""} {
	set prid [pridfromsummaryline $ln]
	set fin [open "|query-pr --full $prid" r]
	set fout [open "|groff -t -ms > $Query(tmpfile)" w]
	formatfullpr $fin $fout
	close $fin
	close $fout
	exec sh -c \
"[format $TkGnats(PSPreviewer) $Query(tmpfile)]\;rm -f $Query(tmpfile)" &
	schedule_reap
    }
}

#
# the write_query functions build queries on eof two ways
# - 1 for a regex aware query-pr (querypr then does most of or work)
# - 2 for a nonregex aware query-pr (we have to query eveything and filter
#					the output ourselves)
#
proc write_query_header {fout procname} {
    global TkGnats Query
    if {$TkGnats(RegexAwareQuerypr)} {
	set Query(query_pr_opts) "-i"
    } else {
	set Query(query_pr_opts) "-i"
    }
    puts $fout "proc $procname \{f\} \{"
    puts $fout "\tupvar 1 \$f flds"
    puts $fout "\tif \{ " nonewline
}

proc write_query_qualifier {fout subclauseop type tag lst} {
    global TkGnats Query
    if {([lsearch -exact $Query(indexed_fields) $tag]>=0) && \
					$TkGnats(RegexAwareQuerypr)} {
	write_regex_query_qualifier $fout $subclauseop $type $tag $lst
	return
    }
    write_dumb_query_qualifier $fout $subclauseop $type $tag $lst
}

proc write_regex_query_qualifier {fout subclauseop type tag lst} {
    global Query
    # set AND or OR subclaus operator
    switch -exact -- $subclauseop -and { 
	set subclauseop & 
    } -or {
	set subclauseop |
    }
    set subclausestr ""
    foreach data $lst {
	set data [string trim $data " \n\t"]
	if {"$data" == ""} {
	    continue
	}
	# first clause , put in leading option stuff
	if {"$subclausestr" == ""} {
	    append Query(query_pr_opts) \
		[format " --%s=" [string tolower $tag]]
	}
	switch -exact -- $type -exact {
	    append Query(query_pr_opts) \
		"$subclausestr^[string range $data 0 15]\$"
	} -glob {
	    append Query(query_pr_opts) "$subclausestr$data"
	}
	set subclausestr $subclauseop
    }

    if {"$subclausestr" == ""} {
	# no clauses were written so just return
	return
    }
}

proc write_dumb_query_qualifier {fout subclauseop type tag lst} {
    # set AND or OR subclaus operator
    switch -exact -- $subclauseop -and { 
	set subclauseop && 
    } -or {
	set subclauseop ||
    }
    set subclausestr ""

    foreach data $lst {
	set data [string trim $data " \n\t"]
	if {"$data" == ""} {
	    continue
	}
	# first clause , put int the leading parens
	if {"$subclausestr" == ""} {
	    puts $fout "\t\t" nonewline
	    puts $fout "( " nonewline
	}
	switch -exact -- $type -exact {
	    puts $fout \
	 "$subclausestr ( \$flds($tag) == \[string range \"$data\"\ 0 15\] ) " \
	    nonewline
	} -glob {
	    puts $fout \
	    "$subclausestr ( \[string match \{$data\} \$flds($tag) \] ) " \
	    nonewline
	}
	set subclausestr "\\\n\t\t\t$subclauseop"
    }

    if {"$subclausestr" == ""} {
	# no clauses were written so just return
	return
    }

    puts $fout ") && \\"
}
 
proc write_mtime_qualifier {fout mtime} {
    global TkGnats GNATS_ROOT Query

    # A problem here is that there's no primitive 
    # to get the current time.  We'll work around that by
    # calling "file mtime" on the file containing the query (pretty gross,
    # eh?)

    set mtime [expr [file mtime $Query(tmpfile)] - $mtime * 24 * 60 * 60]

    puts $fout "\t\t( \[file exists $GNATS_ROOT/\$flds(Category)/\$flds(Number)\] && \\"

    puts $fout "\t\t  \[file mtime $GNATS_ROOT/\$flds(Category)/\$flds(Number)\] <= $mtime ) && \\"

}

proc write_query_trailer {fout} {
    global Query
    puts $fout "\t\t1==1 \\\n\t\} " nonewline
    puts $fout "\{\n\t\treturn 1\n\t\}"
    puts $fout "\treturn 0"
    puts $fout \}

    puts $fout "set default__opts [list $Query(query_pr_opts)]"
}

proc save_query_cmd {{fname ""} {procname ""}} {
    if {$fname == ""} {
	set origp [promptDialog "Enter name of file to save query into"]
	if {"$origp" == ""} {
	    headingMsg "Save cancelled"
	    return
	}
	set p [string trim $origp " \t\n!;'<>?*%$#"]
	if {"$p" == ""} {
	    Msg "'$origp' is not a legal filename"
	}
	set dirname [glob ~]
	set dirname "$dirname/TkGnats"
	exec mkdir -p $dirname
	set fname "$dirname/$p"
    }
    if {"$procname" == ""} {
	set procname ${fname}__query
    }
    set fout [open $fname w]
####set fout stderr; ###### %%
    write_query_header $fout $procname

    # for array globals
    foreach f {
	State Priority Confidential Category Severity Class
    } {
	global $f
	set l {}
	foreach a [array names $f] {
	    lappend l [set [set f]($a)]
	}
	write_query_qualifier $fout -or -exact $f $l
    }

    # the text field values
    foreach f {
	Responsible Synopsis Days-idle Originator
    } {
	if {"[textget $f]" != ""} {
	    switch -exact -- $f Responsible {
		write_query_qualifier $fout -or -exact $f \
		    [split [textget $f] " ,|&"]
	    } Originator {
		write_query_qualifier $fout -or -glob $f \
		    [split [textget $f] " ,|&"]
	    } Synopsis {
		# note that we do *not* split on blanks
		write_query_qualifier $fout -and -glob $f \
		    [split [textget $f] ",|&"]
	    } Days-idle {
		write_mtime_qualifier $fout [textget $f]
	    } default {
		Msg "illegal query text field '$f'"
	    }
	}
    }
    write_query_trailer $fout
    case $fout stderr {
    } default {
	close $fout
    }
    headingMsg "File written as $fname"
}

proc query_cmd {{prid ""}} {
    global lbpath Query Mappings

    if {"$prid" == ""} {
	# Build a query from the widget speicfiers
	save_query_cmd $Query(tmpfile) default__query
	source $Query(tmpfile)
    } else {
	# fetch a specific PR
	proc default__query {flds} {return 1}
    }
    headingMsg "Querying with filter '$Query(sort_cmd)' .."

    if {$prid == ""} {
	set fin [open "|query-pr $default__opts | $Query(sort_cmd)" r]
    } else {
	set fin [open "|query-pr -i $prid | $Query(sort_cmd)" r]
    }
  
    $lbpath delete 0 end; # clear current list
    set c 0
    while {[gets $fin ln] >= 0} {
	incr c
	if {"$ln" == ""} {
	    puts stderr "tkquerypr: warning: line $c empty in query output"
	    puts stderr "Have the gnats administrator check the index file"
	    puts stderr "for bogus entries"
	    continue
	}

	#
	# XXX TBD BUG XXX there is a problemo here if the synopsis
	# has a '|' character in it..
	#
	set l [split $ln "|"]
	set llen [llength $l]
	if {$llen != 14} {
	    puts stderr "tkquerypr: warning: line \"$ln\" has $llen fields."
	    puts stderr "It should have 14 fields. Have the gnats "
	    puts stderr "administrator check the index file for bogus entries."
	    puts stderr "(Especially for |'s in the Synopsis fields)"
	    continue
	}

	    set flds(Number) [string trimright [lindex $l 0] " "]
	    set flds(Category) [string trimright [lindex $l 1] " "]
	    set flds(Synopsis) [string trimright [lindex $l 2] " "]
	    set flds(Confidential) [string trimright [lindex $l 3] " "]
	    set flds(Severity) [string trimright [lindex $l 4] " "]
	    set flds(Priority) [string trimright [lindex $l 5] " "]
	    set flds(Responsible) [string trimright [lindex $l 6] " "]
	    set flds(State) [string trimright [lindex $l 7] " "]
	    set flds(Class) [string trimright [lindex $l 8] " "]
	    set flds(Submitter-Id) [string trimright [lindex $l 9] " "]
	    set flds(Arrival-Date) [string trimright [lindex $l 10] " "]
	    set flds(Originator) [string trimright [lindex $l 11] " "]
	    set flds(Release) [string trimright [lindex $l 12] " "]

	# re-map the numeric fields into text
	foreach f {State Priority Severity Class} {
	    set flds($f) [lindex $Mappings($f) [expr "$flds($f) - 1"]]
	}

	case $flds(Category) "_*" {
		continue
	} default {
	    if {[default__query flds]} {
		set ln [format \
		    "%5d %-11s %-16s %-9s %-8s %-12s %s"\
		    $flds(Number) \
		    $flds(Responsible) \
		    $flds(Category) \
		    $flds(State) \
		    $flds(Priority) \
		    $flds(Severity) \
		    $flds(Synopsis)]
		$lbpath insert end $ln
	    }
	}
    }

    exec rm -f $Query(tmpfile)
    headingMsg "Done"
    close $fin
}

proc medium_report_from_listbox {ln} {
    global Query
    set prnum [pridfromsummaryline $ln]
    workingMsg
    headingMsg "Doing $prnum..."
    exec sh -c "(query-pr $prnum;echo \"\") >> $Query(tmpfile)"
    return 0
}

proc full_report_from_listbox {ln} {
    global Query TkGnats
    set prnum [pridfromsummaryline $ln]
    workingMsg
    headingMsg "Doing $prnum..."
    exec sh -c "query-pr --full $prnum | $TkGnats(PlainPrintSpooler)"
    ## fullreport $no; # this is quite a hog...
    return 0
}
proc perform_query_cmd {{print _list_}} {
    global lbpath Query TkGnats
    headingMsg "Working.."

    case $print {_list_} {
	query_cmd
    } summary_preview {
	write_listbox $lbpath $Query(tmpfile)
	summary_report $Query(tmpfile) preview
	exec rm -f $Query(tmpfile)
    } summary {
	write_listbox $lbpath $Query(tmpfile)
	summary_report $Query(tmpfile)
	exec rm -f $Query(tmpfile)
    } full {
	foreach_listbox $lbpath full_report_from_listbox
    } medium {
	exec rm -f $Query(tmpfile)
	foreach_listbox $lbpath medium_report_from_listbox
	exec sh -c "cat $Query(tmpfile) | $TkGnats(PlainPrintSpooler)"
	exec rm -f $Query(tmpfile)
    }
    headingMsg "Done"
    return
}

#
# filter procs
#
proc filter_get_list {dir} {
    if {![file isdirectory $dir]} {
	tkerror "$dir is not a directory"
    } else {
	return [glob -nocomplain -- $dir/*]
    }
}
proc filter_assemble_menuitems {m dir lboxpath} {
    set flist [filter_get_list $dir]
    foreach f $flist {
	$m add command -label [file tail $f] -command "filter_run $f $lboxpath"
    }
}
proc filter_run {filtname lbox} {
    global GNATS_ROOT
    set lboxsize [$lbox size]
    set filter [open "|$filtname" w]
    for {set i 0} {$i<$lboxsize} {incr i} {
	set ln [$lbox get $i]
	scan $ln "%d %s %s" prid responsible category
	puts $filter  "$GNATS_ROOT/$category/$prid $ln"
    }
    close $filter
}

proc set_query_sorting_cmd {} {
    global Query
    if {[ catch { set rval \
	[exec sortDialog $Query(sort_flds) $Query(sort_flgs)]} errs ]} {
	headingMsg "Sort dialog cancelled. $errs"
	return
    }
    set Query(sort_cmd) $rval
    set_default_sort_criteria $rval
}


proc exit_cmd {} {
    Exit 0
}

#
# ---- Process args
#
proc usage {{exitFlg ""} {str ""}} {
    if {"$str" != ""} {
	puts stderr "tkquerypr: $str"
    }
    puts stderr "tkquerypr usage:\n"
    foreach ln {
	{tkquerypr [-categories 'pattern']}
    } {
	puts stderr "\t$ln"
    }
    if {"$exitFlg" != ""} {
	Exit $exitFlg
    }
}
proc process_args {} {
    global argc argv Query
    if {$argc != 0} {
	if {$argc%2 != 0} {
	    usage 1
	}
	for {set x 0} {$x<$argc} {incr x 2} {
	    set opt [lindex $argv $x]
	    set val [lindex $argv [expr $x+1]]
	    case $opt "-categories" {
		set Query(category_pat) $val
	    } default {
		usage 1 "illegal option pair '$opt $val'"
	    }
	}
    }
}

process_args

#
# ---- Build widgets
#
frame .mframe -borderwidth 1 -relief raised
button .mframe.l -bitmap @$TkGnats(lib)/working1.xbm \
	-command query_from_selection
# bind .mframe.l <B1-ButtonRelease> "query_from_selection"
message .mframe.msg -aspect 10000 
pack append .mframe .mframe.l {left} .mframe.msg {left fillx}
pack append . .mframe {top fillx}

frame .eflds
radiobar_frame .eflds .eflds.lb
checkbar .eflds.lb state State {open analyzed feedback closed suspended} All
checkbar .eflds.lb priority Priority {high medium low} All
checkbar .eflds.lb confidential Confidential {yes no} All
checkbar .eflds.lb severity Severity {non-critical serious critical} All
checkbar .eflds.lb class Class {sw-bug doc-bug change-request support mistaken duplicate} All

frame .eflds.clb
set cbpath [category_listbox .eflds.clb $Query(category_pat)]
pack append .eflds .eflds.lb {left} .eflds.clb {right padx 8}
pack append . .eflds {top fillx}

singletext Responsible 40 ""
singletext Originator 40 ""
singletext Synopsis 40 ""
singletext Days-idle 10 ""

frame .qlb
pack append . .qlb {expand fill}
set lbpath [query_listbox .qlb]

frame .menu -relief raised -borderwidth 2
pack before .qlb .menu {top fillx}

# 
# If there is a filter directory, make a filters menu
#
if {[file isdirectory $TkGnats(FilterDirectory)]} {
    menubutton .menu.filters -text "filters" \
	-menu .menu.filters.m -underline 0
    menu .menu.filters.m
    filter_assemble_menuitems .menu.filters.m $TkGnats(FilterDirectory) $lbpath
    pack append .menu .menu.filters left
}

##
menubutton .menu.print -text "print" -menu .menu.print.m -underline 0
menu .menu.print.m
if {[info exists TkGnats(PSPreviewer)]} {
    set x summary_preview
    .menu.print.m add command -label $x -command "perform_query_cmd $x"
}
foreach x { summary medium full } {
    .menu.print.m add command -label $x -command "perform_query_cmd $x"
}
##
menubutton .menu.query -text "query" -menu .menu.query.m -underline 0
menu .menu.query.m
foreach x { perform_query set_query_sorting} {
    .menu.query.m add command -label $x -command ${x}_cmd
}
##
menubutton .menu.folders -text "folders" -menu .menu.folders.m -underline 0
menu .menu.folders.m
foreach x {view} {
    .menu.folders.m add command -label $x -command folder_${x}_cmd
}
##
menubutton .menu.sel -text "selection" -menu .menu.sel.m -underline 0
menu .menu.sel.m
foreach x {viewSelection editSelection printSelection } {
    .menu.sel.m add command -label $x -command "${x}_cmd $lbpath"
}
if {[info exists TkGnats(PSPreviewer)]} {
    set x previewPrintSelection
    .menu.sel.m add command -label $x -command "${x}_cmd $lbpath"
}

##
menubutton .menu.exit -text "exit" -menu .menu.exit.m -underline 0
menu .menu.exit.m
foreach x { exit } {
    .menu.exit.m add command -label $x -command ${x}_cmd
}

foreach x {
    print query folders sel 
} {
    pack append .menu .menu.$x left
}

pack append .menu .menu.exit right
tk_menuBar .menu .menu.print menu.query
tk_bindForTraversal .

proc headingMsg {s} {
    .mframe.msg configure -text $s
    update
}
wm iconbitmap . @$TkGnats(lib)/tkquerypr.xbm
wm iconname . "$TkGnats(LogName)'s tkquerypr"
