#!/bin/sh
# Copyright (c) 1995 by Sanjay Ghemawat
#

# Tcl sees the next few lines as an assignment to variable `kludge'.
# For sh, the two shifts cancel the effect of the set, and then we
# run calshell on this script.
set kludge { $*
shift
shift
indir="`dirname $0`/brwish"
if test -r "$indir"; then
  exec $indir -f $0 ${1+"$@"}
else
  exec brwish -f $0 ${1+"$@"}
fi
}

##########################################################################
# Listbox operations

# Make labelled box with scrollbar
proc listbox_create {n lab} {
    frame $n

    scrollbar $n.scroll -orient vertical -relief raised -bd 1\
	-command "$n.box yview"
    listbox $n.box -relief raised -bd 1 -yscroll "$n.scroll set"
    label $n.header -text $lab -anchor w -relief raised -bd 1

    pack append $n $n.header {top fillx}
    pack append $n $n.box {left fill expand}
    pack append $n $n.scroll {right filly}
}

# Make labelled box with magic scrollbar that disappears when not needed
proc listbox_create_optional_scroll {n lab} {
    frame $n

    global scrolling
    set scrolling($n) 0
    listbox $n.box -relief raised -bd 1 -yscroll "listbox_change $n"
    scrollbar $n.scroll -orient vertical -relief raised -bd 1\
	-command "$n.box yview"
    label $n.header -text $lab -anchor w -relief raised -bd 1

    pack append $n $n.header {top fillx}
    pack append $n $n.box {left fill expand}
}

# Called when contents of listbox with optional scrollbar change
proc listbox_change {n first last} {
    global scrolling
    if {($first > 0.0) || ($last < 1.0)} {
	# Need scrollbar
	if !$scrolling($n) {
	    place $n.scroll -in $n.box -relx 1 -rely 0 -anchor ne -relheight 1
	    #pack $n.scroll -side right -fill y
	    set scrolling($n) 1
	}
    } else {
	if $scrolling($n) {
	    place forget $n.scroll
	    #pack forget $n.scroll
	    set scrolling($n) 0
	}
    }
    $n.scroll set $first $last
}

# Select an entry in box that matches specified string.
# If nothing matches, then clear selection
proc listbox_select {box string} {
    set index -1
    for {set i 0} {$i < [$box.box size]} {incr i} {
	if {[$box.box get $i] == $string} {
	    set index $i
	    break
	}
    }
    if {$index >= 0} {
	$box.box selection clear 0 end
	$box.box selection set $index
	$box.box see $index
    }
}

##########################################################################
# History operations
#
# history(list) is history list
# history(index) is index of last executed command

proc h_clear {} {
    global history
    set history(list) {}
    set history(index) 0
}

proc h_add {args} {
    global history

    # Trim history list down to current index
    set history(list) [lrange $history(list) 0 $history(index)]

    # Add command
    lappend history(list) $args

    # Change index
    set history(index) [expr "[llength $history(list)] - 1"]
}

proc h_prev {} {
    global history

    if {$history(index) > 0} {
	incr history(index) -1
	eval [lindex $history(list) $history(index)]
    }
}

proc h_next {} {
    global history

    if {$history(index) < ([llength $history(list)] - 1)} {
	incr history(index)
	eval [lindex $history(list) $history(index)]
    }
}

proc h_init {} {
    global history
    set history(list) {}
    set history(index) 0
}

##########################################################################
# Handlers

proc click_class {name} {
    set selection [$name curselection]
    if {$selection != ""} {
	goto_class [$name get [lindex $selection 0]]
    }
}

proc click_func {name} {
    set selection [$name curselection]
    if {$selection != ""} {
	goto_function [$name get [lindex $selection 0]]
    }
}

proc click_method {name} {
    global info

    set selection [$name curselection]
    if {$selection == ""} {return}
    set selection [$name get [lindex $selection 0]]

    if {$info(class) == ""} {return}
    set selection [call $info(class) name]::$selection
    goto_function $selection
}

proc click_selection {} {
    global info

    if [catch {selection get} text] {return}
    if [goto_class $text] {return}
    if [goto_function $text] {return}

    # Show uses if any are found.
    set deleted 0
    forall location in program uses $text {
	if !$deleted {
	    set deleted 1
	    set info(use) -1
	    .use.box delete 0 end
	}
	.use.box insert end $location
    }
}

proc u_prev {} {
    global info
    if {$info(use) > 0} {
	goto_use [expr $info(use)-1]
    }
}

proc u_next {} {
    global info
    if {$info(use) < [expr [.use.box size]-1]} {
	goto_use [expr $info(use)+1]
    }
}

proc click_use {name} {
    set selection [$name curselection]
    if {[llength $selection] == 1} {
	goto_use [lindex $selection 0]
    }
}

proc goto_class {class} {
    if [catch {call program cinfo $class} result] {
	return 0
    }
    h_add show_class $class
    show_class $class
    return 1
}

proc goto_function {function} {
    # Look for unique function name
    if [catch {call program finfo $function} result] {
	# Look for other matches
	forall f in program matches $function {
	    h_add show_function [call $f unique]
	    show_function [call $f unique]
	    return 1
	}
	# Look in overloads
	forall f in program overloads $function {
	    h_add show_function [call $f unique]
	    show_function [call $f unique]
	    return 1
	}
	return 0
    }

    h_add show_function $function
    show_function $function
    return 1
}

proc goto_use {index} {
    global info

    if [catch {set location [.use.box get $index]}] {return}

    set info(use) $index
    .use.box selection clear 0 end
    .use.box selection set $index
    .use.box see $index

    if {[regexp {^ *([0-9]+) +(.+)$} $location junk line file]} {
	show_text $file $line
    }
}


##########################################################################
# Show procs

proc show_class {name} {
    global info

    if [catch {set class [call program cinfo $name]}] {return}

    # Select class name in master class list
    listbox_select .classes [call $class name]

    # Set-up class info
    setup_classlists $class

    # Set-up function info
    set info(function) ""
    set info(use) -1
    .overloads.box delete 0 end

    .use.box delete 0 end
    forall location in program uses [call $class name] {
	.use.box insert end $location
    }

    # Set-up text window
    show_text [call $class file] [call $class line]
}

proc show_function {name} {
    global info

    if [catch {set func [call program finfo $name]}] {return}

    # Set-up function info
    set info(function) $func
    set info(use) -1

    .overloads.box delete 0 end
    forall f in program overloads [call $func unqualified] {
	.overloads.box insert end [call $f unique]
    }

    # Do not display singleton entry in overload box
    if {[.overloads.box size] == 1} {
	.overloads.box delete 0 end
    }

    .use.box delete 0 end
    forall location in program uses [call $func unqualified] {
	.use.box insert end $location
    }

    # Set-up class info
    if [catch {call program cinfo [call $func scope]} class] {
	# No class
	set info(class) ""
	.parents.box delete 0 end
	.children.box delete 0 end
	.siblings.box delete 0 end
	.methods.box delete 0 end
    } else {
	setup_classlists $class
    }

    # Select function name in master function/method list
    if {[call $func scope] == ""} {
	if [call $func isdef] {
	    listbox_select .defines [call $func unique]
	} else {
	    listbox_select .defines [call $func unique]
	}
    } else {
	listbox_select .methods [call $func unique]
    }

    # Set-up text window
    show_text [call $func file] [call $func line]
}

# Setup class lists for specified class
proc setup_classlists {class} {
    global info

    if {$info(class) == $class} {return}
    set info(class) $class

    # Display parents
    .parents.box delete 0 end
    forall x in $class parents {
	.parents.box insert end $x
    }

    # Display children
    .children.box delete 0 end
    forall x in $class children {
	.children.box insert end $x
    }

    # Display siblings
    .siblings.box delete 0 end
    foreach c [find_sibling_names $class] {
	.siblings.box insert end $c
    }

    # Display methods
    .methods.box delete 0 end
    forall x in $class methods {
	regsub -- ^[call $class name]:: $x "" x
	.methods.box insert end $x
    }
}

# Redisplay text with new options
proc redisplay_text {} {
    global info
    if [string compare $info(file) ""] {
	set file $info(file)
	set info(file) ""
	set line [expr round([.t.text index @0,0])]
	show_text $file $line
    }
}

# Show specified <file/line> in text window
proc show_text {file line} {
    global info ground
    if {$info(file) != $file} {
	# Load the new file
	set info(file) $file
	wm title .t $file

	.t.text delete 0.0 end

	# Create ground code if necessary
	if $info(grind) {
	    if ![info exists ground($file)] {
		catch {set ground($file) [exec grind -tk $file]}
	    }
        }

	if {$info(grind) && [info exists ground($file)]} {
	    set text .t.text
	    eval $ground($file)

	    global grindtag
	    foreach k [array names grindtag] {
		eval [list $text tag configure $k] $grindtag($k)
	    }
	} else {
	    if ![catch {open $file r} id] {
		catch {.t.text insert 0.0 [read $id nonewline]}
		catch {close $id}
	    }
	}
    }

    # Goto line
    .t.text yview [expr "$line-1"]
}

##########################################################################
# Miscellaneous

proc find_sibling_names {class} {
    # Create array for stashing away names of children
    set cl(junk) 1
    unset cl(junk)

    forall p in $class parents {
	if [catch {set p [call program cinfo $p]}] {continue}
	forall c in $p children {
	    set cl($c) 1
	}
    }

    return [lsort [array names cl]]
}

##########################################################################
# Feedback box

proc feedback_post {title label total} {
    if ![winfo exists .fb] {
	feedback_build .fb
    }

    place .fb -relx 0.5 -rely 0.5 -anchor center

    .fb.msg configure -text $title
    .fb.lab configure -text Foo
    .fb.scale configure -label $label
    .fb.scale configure -from 0 -to $total
    .fb.scale set 0
    .fb.scale configure -state disabled
}

proc feedback_build {w} {
    frame $w

    label $w.title -text Feedback -relief raised -bd 1
    message $w.msg -aspect 400 -padx 5m -pady 5m -relief raised -bd 1
    label $w.lab -padx 5m -pady 5m -relief raised -bd 1

    frame $w.mid -relief raised -bd 1
    frame $w.mid.in
    scale $w.scale -orient horizontal -length 5i -showvalue 1\
	-tickinterval 0

    pack $w.scale -in $w.mid.in -side top -fill both -expand 1
    pack $w.mid.in -side top -fill both -expand 1

    pack $w.title -side top -expand 1 -fill x
    pack $w.msg -side top -fill both
    pack $w.mid -side top -fill both -expand 1
    pack $w.lab -side top -fill x
}

proc feedback_withdraw {} {
    place forget .fb
}

proc feedback_update {label count} {
    .fb.lab configure -text $label
    .fb.scale configure -state normal
    .fb.scale set $count
    .fb.scale configure -state disabled
    update
}

##########################################################################
# Rescan files

proc loadfiles {} {
    global info

    set files {}
    set bytes 0
    foreach dir $info(dirs) {
	if [file isdirectory $dir] {
	    set flist [glob -nocomplain $dir/*.{h,c,cc,C}]
	} else {
	    set flist [list $dir]
	}

	foreach f $flist {
	    if [catch {file stat $f stat}] {continue}
	    if [string compare $stat(type) file] {continue}

	    incr bytes $stat(size)
	    lappend files $f
	    set size($f) $stat(size)
	}
    }
    set files [lsort $files]

    # Cannot unload a file while iterating through loaded files
    # because the iterator depends on the contents of the file list
    # not changing for the duration of the iteration.  So we stash
    # away the file list in a Tcl list and then iterate through the
    # list.

    set old {}
    forall f in program files {lappend old $f}
    foreach f $old {
	call program unload $f
    }

    set total [llength $files]
    if {$total == 0} {return}
    feedback_post "Loading $total files containing $bytes bytes..."\
	"Bytes" $bytes

    set count 0
    foreach f $files {
	feedback_update "Load $f" $count
	call program load $f
	incr count $size($f)
    }

    .classes.box	delete 0 end
    .methods.box	delete 0 end
    .parents.box	delete 0 end
    .children.box	delete 0 end
    .siblings.box	delete 0 end
    .functions.box	delete 0 end
    .defines.box	delete 0 end
    .overloads.box	delete 0 end
    .use.box		delete 0 end
    .t.text		delete 0.0 end

    global info
    set info(file) ""

    feedback_update "Sorting Information" $count
    call program sort

    feedback_update "Fetching Classes" $count
    forall c in program classes {.classes.box insert end [call $c name]}

    feedback_update "Fetching Functions" $count
    forall f in program funclist {
	.functions.box insert end $f
    }

    feedback_update "Fetching Defines" $count
    forall f in program deflist {
	.defines.box insert end $f
    }

    feedback_withdraw

    # Remove cached grind output
    catch {unset ground}
}

##########################################################################
# Editor invocation

proc edit_file {} {
    global info

    if [file exists $info(file)] {
	set line [lindex [.t.scroll get] 2]
	exec emacs +$line $info(file) &
    }
}

##########################################################################
# Info Initialization

proc info_init {} {
    global info

    programinfo program
    set info(class) ""
    set info(function) ""
    set info(use) -1
    set info(file) ""
}

##########################################################################
# Create Interface

proc interface_init {} {
    set cwidth 15
    set fwidth 18

    frame .l -relief flat -bd 0
    frame .topf -bd 0 -relief flat
    frame .claux1 -bd 0 -relief flat
    frame .claux2 -bd 0 -relief flat

    listbox_create .classes Classes
    .classes.box configure -width $cwidth -height 10
    bind .classes.box <ButtonRelease-1> "click_class %W"
    bind .classes.box <Shift-ButtonRelease-1> "click_class %W"

    listbox_create .methods Methods
    .methods.box configure -width $fwidth -height 6
    bind .methods.box <ButtonRelease-1> "click_method %W"
    bind .methods.box <Shift-ButtonRelease-1> "click_method %W"

    listbox_create_optional_scroll .overloads Overloads
    .overloads.box configure -width $fwidth -height 3
    bind .overloads.box <ButtonRelease-1> "click_func %W"
    bind .overloads.box <Shift-ButtonRelease-1> "click_func %W"

    listbox_create_optional_scroll .parents Parents
    .parents.box configure -width $cwidth -height 2
    bind .parents.box <ButtonRelease-1> "click_class %W"
    bind .parents.box <Shift-ButtonRelease-1> "click_class %W"

    listbox_create_optional_scroll .children Children
    .children.box configure -width $cwidth -height 3
    bind .children.box <ButtonRelease-1> "click_class %W"
    bind .children.box <Shift-ButtonRelease-1> "click_class %W"

    listbox_create_optional_scroll .siblings Siblings
    .siblings.box configure -width $cwidth -height 3
    bind .siblings.box <ButtonRelease-1> "click_class %W"
    bind .siblings.box <Shift-ButtonRelease-1> "click_class %W"

    listbox_create .functions Functions
    .functions.box configure -width $fwidth -height 8
    bind .functions.box <ButtonRelease-1> "click_func %W"
    bind .functions.box <Shift-ButtonRelease-1> "click_func %W"

    listbox_create .defines Defines
    .functions.box configure -width $fwidth -height 8
    bind .defines.box <ButtonRelease-1> "click_func %W"
    bind .defines.box <Shift-ButtonRelease-1> "click_func %W"

    listbox_create .use Use
    .use.box configure -width $fwidth -height 15 -exportselection 0
    bind .use.box <ButtonRelease-1> "click_use %W"
    bind .use.box <Shift-ButtonRelease-1> "click_use %W"

    # Create text display
    toplevel .t
    scrollbar .t.scroll -orient vertical -relief raised -bd 1\
	-command ".t.text yview"
    text .t.text -relief raised -bd 1 -yscroll ".t.scroll set"\
	-height 30 -width 60 -selectborderwidth 0 -wrap none
    bind .t.text <Triple-Button-1> {click_selection;break}
    pack .t.scroll -side right -fill y
    pack .t.text -side left -fill both -expand 1

    # Create menus
    frame .menubar -relief raised -bd 1

    menubutton .menubar.goto -text "Goto" -menu .menubar.goto.m
    menu .menubar.goto.m
    .menubar.goto.m add command -label "Selection" -command click_selection
    .menubar.goto.m add separator
    .menubar.goto.m add command -label "Last Item" -command h_prev
    .menubar.goto.m add command -label "Next Item" -command h_next
    .menubar.goto.m add separator
    .menubar.goto.m add command -label "Last Use" -command u_prev
    .menubar.goto.m add command -label "Next Use" -command u_next
    .menubar.goto.m entryconfig Sele* -accel "  ^G"
    .menubar.goto.m entryconfig {Last Item} -accel "  ^P"
    .menubar.goto.m entryconfig {Next Item} -accel "  ^N"
    .menubar.goto.m entryconfig {Last Use} -accel "  ^R"
    .menubar.goto.m entryconfig {Next Use} -accel "  ^S"
    
    menubutton .menubar.file -text "File" -menu .menubar.file.m
    menu .menubar.file.m
    .menubar.file.m add command -label "Edit"   -command edit_file
    .menubar.file.m add command -label "Rescan" -command loadfiles
    .menubar.file.m add separator
    .menubar.file.m add command -label "Quit" -command exit
    
    .menubar.file.m entryconfig Edit* -accel "  ^E"
    .menubar.file.m entryconfig Resc* -accel "  ^L"
    .menubar.file.m entryconfig Quit* -accel "  ^C"

    menubutton .menubar.options -text "Options" -menu .menubar.options.m
    menu .menubar.options.m
    .menubar.options.m add checkbutton\
	-label "Pretty Print"\
	-onvalue 1\
	-offvalue 0\
	-variable info(grind)\
	-command {redisplay_text}
    
    tk_menuBar .menubar .menubar.file .menubar.goto .menubar.options
    
    pack append .menubar .menubar.file left
    pack append .menubar .menubar.goto left
    pack append .menubar .menubar.options left

    packit

    .t.text configure -setgrid 1
    wm minsize [winfo toplevel .t] 50 20
    wm maxsize [winfo toplevel .t] 120 80
}

##########################################################################
# Packing

proc packit {} {
    .classes.box configure -width 18 -height 10
    .overloads.box configure -width 20 -height 6

    # Auxiliary class boxes
    pack .classes	-in .claux1 -side top -expand 1 -fill both
    pack .parents	-in .claux1 -side top -expand 1 -fill both
    pack .children	-in .claux1 -side top -expand 1 -fill both
    pack .siblings	-in .claux1 -side top -expand 1 -fill both

    pack .methods	-in .claux2 -side top -expand 1 -fill both
    pack .overloads	-in .claux2 -side top -expand 1 -fill both

    # Right side
    pack .defines	-in .l -side top -expand 1 -fill both
    pack .functions	-in .l -side top -expand 1 -fill both
    pack .use		-in .l -side top -expand 1 -fill both

    # Top boxes
    pack .claux1	-in .topf -side left -fill both -expand 1
    pack .claux2	-in .topf -side left -fill both -expand 1

    # Overall packing
    pack .menubar	-side top -fill x
    pack .l		-side left -fill both
    pack .topf		-side left -fill both
}

##########################################################################
# Keyboard Accelerators

proc key_init {} {
    focus .t.text

    bind all <Control-e> edit_file
    bind all <Control-l> loadfiles
    bind all <Control-c> exit

    bind all <Control-g> click_selection
    bind all <Control-p> h_prev
    bind all <Control-n> h_next
    bind all <Control-r> u_prev
    bind all <Control-s> u_next
}

##########################################################################
# Check to see if "grind" is available for formatting code.

proc grind_init {} {
    global info env grindtag
    set info(grind) 0

    # Set-up tagging info
    if [string match *color* [winfo screenvisual .]] {
	set grindtag(keyword)	{-foreground blue}
	set grindtag(comment)	{-foreground purple}
	set grindtag(emphasis)	{-foreground red}
    } else {
	set grindtag(keyword)	{-underline 1}
	set grindtag(emphasis)	{-underline 1}
    }

    # Disable grind (its too slow)
    # return

    # Search in PATH
    foreach dir [split $env(PATH) :] {
	if [file executable $dir/grind] {
	    set info(grind) 1
	    break
	}
    }
}

##########################################################################
# Initialization

set info(dirs) [list .]
if [string compare $argv ""] {set info(dirs) $argv}

h_init
info_init
grind_init
interface_init
key_init
update
loadfiles
