blob: 5560e4dc560587c4a551c24a1ee59df394726fc9 [file] [log] [blame]
#!/bin/sh
# Tcl ignores the next line -*- tcl -*- \
exec wish "$0" -- "$@"
# Copyright (C) 2005-2006 Paul Mackerras. All rights reserved.
# This program is free software; it may be used, copied, modified
# and distributed under the terms of the GNU General Public Licence,
# either version 2, or (at your option) any later version.
proc gitdir {} {
global env
if {[info exists env(GIT_DIR)]} {
return $env(GIT_DIR)
} else {
return [exec git rev-parse --git-dir]
}
}
# A simple scheduler for compute-intensive stuff.
# The aim is to make sure that event handlers for GUI actions can
# run at least every 50-100 ms. Unfortunately fileevent handlers are
# run before X event handlers, so reading from a fast source can
# make the GUI completely unresponsive.
proc run args {
global isonrunq runq
set script $args
if {[info exists isonrunq($script)]} return
if {$runq eq {}} {
after idle dorunq
}
lappend runq [list {} $script]
set isonrunq($script) 1
}
proc filerun {fd script} {
fileevent $fd readable [list filereadable $fd $script]
}
proc filereadable {fd script} {
global runq
fileevent $fd readable {}
if {$runq eq {}} {
after idle dorunq
}
lappend runq [list $fd $script]
}
proc dorunq {} {
global isonrunq runq
set tstart [clock clicks -milliseconds]
set t0 $tstart
while {$runq ne {}} {
set fd [lindex $runq 0 0]
set script [lindex $runq 0 1]
set repeat [eval $script]
set t1 [clock clicks -milliseconds]
set t [expr {$t1 - $t0}]
set runq [lrange $runq 1 end]
if {$repeat ne {} && $repeat} {
if {$fd eq {} || $repeat == 2} {
# script returns 1 if it wants to be readded
# file readers return 2 if they could do more straight away
lappend runq [list $fd $script]
} else {
fileevent $fd readable [list filereadable $fd $script]
}
} elseif {$fd eq {}} {
unset isonrunq($script)
}
set t0 $t1
if {$t1 - $tstart >= 80} break
}
if {$runq ne {}} {
after idle dorunq
}
}
# Start off a git rev-list process and arrange to read its output
proc start_rev_list {view} {
global startmsecs
global commfd leftover tclencoding datemode
global viewargs viewfiles commitidx viewcomplete vnextroot
global showlocalchanges commitinterest mainheadid
global progressdirn progresscoords proglastnc curview
set startmsecs [clock clicks -milliseconds]
set commitidx($view) 0
set viewcomplete($view) 0
set vnextroot($view) 0
set order "--topo-order"
if {$datemode} {
set order "--date-order"
}
if {[catch {
set fd [open [concat | git log --no-color -z --pretty=raw $order --parents \
--boundary $viewargs($view) "--" $viewfiles($view)] r]
} err]} {
error_popup "[mc "Error executing git rev-list:"] $err"
exit 1
}
set commfd($view) $fd
set leftover($view) {}
if {$showlocalchanges} {
lappend commitinterest($mainheadid) {dodiffindex}
}
fconfigure $fd -blocking 0 -translation lf -eofchar {}
if {$tclencoding != {}} {
fconfigure $fd -encoding $tclencoding
}
filerun $fd [list getcommitlines $fd $view]
nowbusy $view [mc "Reading"]
if {$view == $curview} {
set progressdirn 1
set progresscoords {0 0}
set proglastnc 0
}
}
proc stop_rev_list {} {
global commfd curview
if {![info exists commfd($curview)]} return
set fd $commfd($curview)
catch {
set pid [pid $fd]
exec kill $pid
}
catch {close $fd}
unset commfd($curview)
}
proc getcommits {} {
global phase canv curview
set phase getcommits
initlayout
start_rev_list $curview
show_status [mc "Reading commits..."]
}
# This makes a string representation of a positive integer which
# sorts as a string in numerical order
proc strrep {n} {
if {$n < 16} {
return [format "%x" $n]
} elseif {$n < 256} {
return [format "x%.2x" $n]
} elseif {$n < 65536} {
return [format "y%.4x" $n]
}
return [format "z%.8x" $n]
}
proc getcommitlines {fd view} {
global commitlisted commitinterest
global leftover commfd
global displayorder commitidx viewcomplete commitrow commitdata
global parentlist children curview hlview
global vparentlist vdisporder vcmitlisted
global ordertok vnextroot idpending
set stuff [read $fd 500000]
# git log doesn't terminate the last commit with a null...
if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
set stuff "\0"
}
if {$stuff == {}} {
if {![eof $fd]} {
return 1
}
# Check if we have seen any ids listed as parents that haven't
# appeared in the list
foreach vid [array names idpending "$view,*"] {
# should only get here if git log is buggy
set id [lindex [split $vid ","] 1]
set commitrow($vid) $commitidx($view)
incr commitidx($view)
if {$view == $curview} {
lappend parentlist {}
lappend displayorder $id
lappend commitlisted 0
} else {
lappend vparentlist($view) {}
lappend vdisporder($view) $id
lappend vcmitlisted($view) 0
}
}
set viewcomplete($view) 1
global viewname progresscoords
unset commfd($view)
notbusy $view
set progresscoords {0 0}
adjustprogress
# set it blocking so we wait for the process to terminate
fconfigure $fd -blocking 1
if {[catch {close $fd} err]} {
set fv {}
if {$view != $curview} {
set fv " for the \"$viewname($view)\" view"
}
if {[string range $err 0 4] == "usage"} {
set err "Gitk: error reading commits$fv:\
bad arguments to git rev-list."
if {$viewname($view) eq "Command line"} {
append err \
" (Note: arguments to gitk are passed to git rev-list\
to allow selection of commits to be displayed.)"
}
} else {
set err "Error reading commits$fv: $err"
}
error_popup $err
}
if {$view == $curview} {
run chewcommits $view
}
return 0
}
set start 0
set gotsome 0
while 1 {
set i [string first "\0" $stuff $start]
if {$i < 0} {
append leftover($view) [string range $stuff $start end]
break
}
if {$start == 0} {
set cmit $leftover($view)
append cmit [string range $stuff 0 [expr {$i - 1}]]
set leftover($view) {}
} else {
set cmit [string range $stuff $start [expr {$i - 1}]]
}
set start [expr {$i + 1}]
set j [string first "\n" $cmit]
set ok 0
set listed 1
if {$j >= 0 && [string match "commit *" $cmit]} {
set ids [string range $cmit 7 [expr {$j - 1}]]
if {[string match {[-<>]*} $ids]} {
switch -- [string index $ids 0] {
"-" {set listed 0}
"<" {set listed 2}
">" {set listed 3}
}
set ids [string range $ids 1 end]
}
set ok 1
foreach id $ids {
if {[string length $id] != 40} {
set ok 0
break
}
}
}
if {!$ok} {
set shortcmit $cmit
if {[string length $shortcmit] > 80} {
set shortcmit "[string range $shortcmit 0 80]..."
}
error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
exit 1
}
set id [lindex $ids 0]
if {![info exists ordertok($view,$id)]} {
set otok "o[strrep $vnextroot($view)]"
incr vnextroot($view)
set ordertok($view,$id) $otok
} else {
set otok $ordertok($view,$id)
unset idpending($view,$id)
}
if {$listed} {
set olds [lrange $ids 1 end]
if {[llength $olds] == 1} {
set p [lindex $olds 0]
lappend children($view,$p) $id
if {![info exists ordertok($view,$p)]} {
set ordertok($view,$p) $ordertok($view,$id)
set idpending($view,$p) 1
}
} else {
set i 0
foreach p $olds {
if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
lappend children($view,$p) $id
}
if {![info exists ordertok($view,$p)]} {
set ordertok($view,$p) "$otok[strrep $i]]"
set idpending($view,$p) 1
}
incr i
}
}
} else {
set olds {}
}
if {![info exists children($view,$id)]} {
set children($view,$id) {}
}
set commitdata($id) [string range $cmit [expr {$j + 1}] end]
set commitrow($view,$id) $commitidx($view)
incr commitidx($view)
if {$view == $curview} {
lappend parentlist $olds
lappend displayorder $id
lappend commitlisted $listed
} else {
lappend vparentlist($view) $olds
lappend vdisporder($view) $id
lappend vcmitlisted($view) $listed
}
if {[info exists commitinterest($id)]} {
foreach script $commitinterest($id) {
eval [string map [list "%I" $id] $script]
}
unset commitinterest($id)
}
set gotsome 1
}
if {$gotsome} {
run chewcommits $view
if {$view == $curview} {
# update progress bar
global progressdirn progresscoords proglastnc
set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
set proglastnc $commitidx($view)
set l [lindex $progresscoords 0]
set r [lindex $progresscoords 1]
if {$progressdirn} {
set r [expr {$r + $inc}]
if {$r >= 1.0} {
set r 1.0
set progressdirn 0
}
if {$r > 0.2} {
set l [expr {$r - 0.2}]
}
} else {
set l [expr {$l - $inc}]
if {$l <= 0.0} {
set l 0.0
set progressdirn 1
}
set r [expr {$l + 0.2}]
}
set progresscoords [list $l $r]
adjustprogress
}
}
return 2
}
proc chewcommits {view} {
global curview hlview viewcomplete
global selectedline pending_select
if {$view == $curview} {
layoutmore
if {$viewcomplete($view)} {
global displayorder commitidx phase
global numcommits startmsecs
if {[info exists pending_select]} {
set row [first_real_row]
selectline $row 1
}
if {$commitidx($curview) > 0} {
#set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
#puts "overall $ms ms for $numcommits commits"
} else {
show_status [mc "No commits selected"]
}
notbusy layout
set phase {}
}
}
if {[info exists hlview] && $view == $hlview} {
vhighlightmore
}
return 0
}
proc readcommit {id} {
if {[catch {set contents [exec git cat-file commit $id]}]} return
parsecommit $id $contents 0
}
proc updatecommits {} {
global viewdata curview phase displayorder ordertok idpending
global children commitrow selectedline thickerline showneartags
if {$phase ne {}} {
stop_rev_list
set phase {}
}
set n $curview
foreach id $displayorder {
catch {unset children($n,$id)}
catch {unset commitrow($n,$id)}
catch {unset ordertok($n,$id)}
}
foreach vid [array names idpending "$n,*"] {
unset idpending($vid)
}
set curview -1
catch {unset selectedline}
catch {unset thickerline}
catch {unset viewdata($n)}
readrefs
changedrefs
if {$showneartags} {
getallcommits
}
showview $n
}
proc parsecommit {id contents listed} {
global commitinfo cdate
set inhdr 1
set comment {}
set headline {}
set auname {}
set audate {}
set comname {}
set comdate {}
set hdrend [string first "\n\n" $contents]
if {$hdrend < 0} {
# should never happen...
set hdrend [string length $contents]
}
set header [string range $contents 0 [expr {$hdrend - 1}]]
set comment [string range $contents [expr {$hdrend + 2}] end]
foreach line [split $header "\n"] {
set tag [lindex $line 0]
if {$tag == "author"} {
set audate [lindex $line end-1]
set auname [lrange $line 1 end-2]
} elseif {$tag == "committer"} {
set comdate [lindex $line end-1]
set comname [lrange $line 1 end-2]
}
}
set headline {}
# take the first non-blank line of the comment as the headline
set headline [string trimleft $comment]
set i [string first "\n" $headline]
if {$i >= 0} {
set headline [string range $headline 0 $i]
}
set headline [string trimright $headline]
set i [string first "\r" $headline]
if {$i >= 0} {
set headline [string trimright [string range $headline 0 $i]]
}
if {!$listed} {
# git rev-list indents the comment by 4 spaces;
# if we got this via git cat-file, add the indentation
set newcomment {}
foreach line [split $comment "\n"] {
append newcomment " "
append newcomment $line
append newcomment "\n"
}
set comment $newcomment
}
if {$comdate != {}} {
set cdate($id) $comdate
}
set commitinfo($id) [list $headline $auname $audate \
$comname $comdate $comment]
}
proc getcommit {id} {
global commitdata commitinfo
if {[info exists commitdata($id)]} {
parsecommit $id $commitdata($id) 1
} else {
readcommit $id
if {![info exists commitinfo($id)]} {
set commitinfo($id) [list [mc "No commit information available"]]
}
}
return 1
}
proc readrefs {} {
global tagids idtags headids idheads tagobjid
global otherrefids idotherrefs mainhead mainheadid
foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
catch {unset $v}
}
set refd [open [list | git show-ref -d] r]
while {[gets $refd line] >= 0} {
if {[string index $line 40] ne " "} continue
set id [string range $line 0 39]
set ref [string range $line 41 end]
if {![string match "refs/*" $ref]} continue
set name [string range $ref 5 end]
if {[string match "remotes/*" $name]} {
if {![string match "*/HEAD" $name]} {
set headids($name) $id
lappend idheads($id) $name
}
} elseif {[string match "heads/*" $name]} {
set name [string range $name 6 end]
set headids($name) $id
lappend idheads($id) $name
} elseif {[string match "tags/*" $name]} {
# this lets refs/tags/foo^{} overwrite refs/tags/foo,
# which is what we want since the former is the commit ID
set name [string range $name 5 end]
if {[string match "*^{}" $name]} {
set name [string range $name 0 end-3]
} else {
set tagobjid($name) $id
}
set tagids($name) $id
lappend idtags($id) $name
} else {
set otherrefids($name) $id
lappend idotherrefs($id) $name
}
}
catch {close $refd}
set mainhead {}
set mainheadid {}
catch {
set thehead [exec git symbolic-ref HEAD]
if {[string match "refs/heads/*" $thehead]} {
set mainhead [string range $thehead 11 end]
if {[info exists headids($mainhead)]} {
set mainheadid $headids($mainhead)
}
}
}
}
# skip over fake commits
proc first_real_row {} {
global nullid nullid2 displayorder numcommits
for {set row 0} {$row < $numcommits} {incr row} {
set id [lindex $displayorder $row]
if {$id ne $nullid && $id ne $nullid2} {
break
}
}
return $row
}
# update things for a head moved to a child of its previous location
proc movehead {id name} {
global headids idheads
removehead $headids($name) $name
set headids($name) $id
lappend idheads($id) $name
}
# update things when a head has been removed
proc removehead {id name} {
global headids idheads
if {$idheads($id) eq $name} {
unset idheads($id)
} else {
set i [lsearch -exact $idheads($id) $name]
if {$i >= 0} {
set idheads($id) [lreplace $idheads($id) $i $i]
}
}
unset headids($name)
}
proc show_error {w top msg} {
message $w.m -text $msg -justify center -aspect 400
pack $w.m -side top -fill x -padx 20 -pady 20
button $w.ok -text [mc OK] -command "destroy $top"
pack $w.ok -side bottom -fill x
bind $top <Visibility> "grab $top; focus $top"
bind $top <Key-Return> "destroy $top"
tkwait window $top
}
proc error_popup msg {
set w .error
toplevel $w
wm transient $w .
show_error $w $w $msg
}
proc confirm_popup msg {
global confirm_ok
set confirm_ok 0
set w .confirm
toplevel $w
wm transient $w .
message $w.m -text $msg -justify center -aspect 400
pack $w.m -side top -fill x -padx 20 -pady 20
button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
pack $w.ok -side left -fill x
button $w.cancel -text [mc Cancel] -command "destroy $w"
pack $w.cancel -side right -fill x
bind $w <Visibility> "grab $w; focus $w"
tkwait window $w
return $confirm_ok
}
proc setoptions {} {
option add *Panedwindow.showHandle 1 startupFile
option add *Panedwindow.sashRelief raised startupFile
option add *Button.font uifont startupFile
option add *Checkbutton.font uifont startupFile
option add *Radiobutton.font uifont startupFile
option add *Menu.font uifont startupFile
option add *Menubutton.font uifont startupFile
option add *Label.font uifont startupFile
option add *Message.font uifont startupFile
option add *Entry.font uifont startupFile
}
proc makewindow {} {
global canv canv2 canv3 linespc charspc ctext cflist
global tabstop
global findtype findtypemenu findloc findstring fstring geometry
global entries sha1entry sha1string sha1but
global diffcontextstring diffcontext
global maincursor textcursor curtextcursor
global rowctxmenu fakerowmenu mergemax wrapcomment
global highlight_files gdttype
global searchstring sstring
global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
global headctxmenu progresscanv progressitem progresscoords statusw
global fprogitem fprogcoord lastprogupdate progupdatepending
global rprogitem rprogcoord
global have_tk85
menu .bar
.bar add cascade -label [mc "File"] -menu .bar.file
menu .bar.file
.bar.file add command -label [mc "Update"] -command updatecommits
.bar.file add command -label [mc "Reread references"] -command rereadrefs
.bar.file add command -label [mc "List references"] -command showrefs
.bar.file add command -label [mc "Quit"] -command doquit
menu .bar.edit
.bar add cascade -label [mc "Edit"] -menu .bar.edit
.bar.edit add command -label [mc "Preferences"] -command doprefs
menu .bar.view
.bar add cascade -label [mc "View"] -menu .bar.view
.bar.view add command -label [mc "New view..."] -command {newview 0}
.bar.view add command -label [mc "Edit view..."] -command editview \
-state disabled
.bar.view add command -label [mc "Delete view"] -command delview -state disabled
.bar.view add separator
.bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
-variable selectedview -value 0
menu .bar.help
.bar add cascade -label [mc "Help"] -menu .bar.help
.bar.help add command -label [mc "About gitk"] -command about
.bar.help add command -label [mc "Key bindings"] -command keys
.bar.help configure
. configure -menu .bar
# the gui has upper and lower half, parts of a paned window.
panedwindow .ctop -orient vertical
# possibly use assumed geometry
if {![info exists geometry(pwsash0)]} {
set geometry(topheight) [expr {15 * $linespc}]
set geometry(topwidth) [expr {80 * $charspc}]
set geometry(botheight) [expr {15 * $linespc}]
set geometry(botwidth) [expr {50 * $charspc}]
set geometry(pwsash0) "[expr {40 * $charspc}] 2"
set geometry(pwsash1) "[expr {60 * $charspc}] 2"
}
# the upper half will have a paned window, a scroll bar to the right, and some stuff below
frame .tf -height $geometry(topheight) -width $geometry(topwidth)
frame .tf.histframe
panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
# create three canvases
set cscroll .tf.histframe.csb
set canv .tf.histframe.pwclist.canv
canvas $canv \
-selectbackground $selectbgcolor \
-background $bgcolor -bd 0 \
-yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
.tf.histframe.pwclist add $canv
set canv2 .tf.histframe.pwclist.canv2
canvas $canv2 \
-selectbackground $selectbgcolor \
-background $bgcolor -bd 0 -yscrollincr $linespc
.tf.histframe.pwclist add $canv2
set canv3 .tf.histframe.pwclist.canv3
canvas $canv3 \
-selectbackground $selectbgcolor \
-background $bgcolor -bd 0 -yscrollincr $linespc
.tf.histframe.pwclist add $canv3
eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
# a scroll bar to rule them
scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
pack $cscroll -side right -fill y
bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
lappend bglist $canv $canv2 $canv3
pack .tf.histframe.pwclist -fill both -expand 1 -side left
# we have two button bars at bottom of top frame. Bar 1
frame .tf.bar
frame .tf.lbar -height 15
set sha1entry .tf.bar.sha1
set entries $sha1entry
set sha1but .tf.bar.sha1label
button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
-command gotocommit -width 8
$sha1but conf -disabledforeground [$sha1but cget -foreground]
pack .tf.bar.sha1label -side left
entry $sha1entry -width 40 -font textfont -textvariable sha1string
trace add variable sha1string write sha1change
pack $sha1entry -side left -pady 2
image create bitmap bm-left -data {
#define left_width 16
#define left_height 16
static unsigned char left_bits[] = {
0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
}
image create bitmap bm-right -data {
#define right_width 16
#define right_height 16
static unsigned char right_bits[] = {
0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
}
button .tf.bar.leftbut -image bm-left -command goback \
-state disabled -width 26
pack .tf.bar.leftbut -side left -fill y
button .tf.bar.rightbut -image bm-right -command goforw \
-state disabled -width 26
pack .tf.bar.rightbut -side left -fill y
# Status label and progress bar
set statusw .tf.bar.status
label $statusw -width 15 -relief sunken
pack $statusw -side left -padx 5
set h [expr {[font metrics uifont -linespace] + 2}]
set progresscanv .tf.bar.progress
canvas $progresscanv -relief sunken -height $h -borderwidth 2
set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
pack $progresscanv -side right -expand 1 -fill x
set progresscoords {0 0}
set fprogcoord 0
set rprogcoord 0
bind $progresscanv <Configure> adjustprogress
set lastprogupdate [clock clicks -milliseconds]
set progupdatepending 0
# build up the bottom bar of upper window
label .tf.lbar.flabel -text "[mc "Find"] "
button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
label .tf.lbar.flab2 -text " [mc "commit"] "
pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
-side left -fill y
set gdttype [mc "containing:"]
set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
[mc "containing:"] \
[mc "touching paths:"] \
[mc "adding/removing string:"]]
trace add variable gdttype write gdttype_change
pack .tf.lbar.gdttype -side left -fill y
set findstring {}
set fstring .tf.lbar.findstring
lappend entries $fstring
entry $fstring -width 30 -font textfont -textvariable findstring
trace add variable findstring write find_change
set findtype [mc "Exact"]
set findtypemenu [tk_optionMenu .tf.lbar.findtype \
findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
trace add variable findtype write findcom_change
set findloc [mc "All fields"]
tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
[mc "Comments"] [mc "Author"] [mc "Committer"]
trace add variable findloc write find_change
pack .tf.lbar.findloc -side right
pack .tf.lbar.findtype -side right
pack $fstring -side left -expand 1 -fill x
# Finish putting the upper half of the viewer together
pack .tf.lbar -in .tf -side bottom -fill x
pack .tf.bar -in .tf -side bottom -fill x
pack .tf.histframe -fill both -side top -expand 1
.ctop add .tf
.ctop paneconfigure .tf -height $geometry(topheight)
.ctop paneconfigure .tf -width $geometry(topwidth)
# now build up the bottom
panedwindow .pwbottom -orient horizontal
# lower left, a text box over search bar, scroll bar to the right
# if we know window height, then that will set the lower text height, otherwise
# we set lower text height which will drive window height
if {[info exists geometry(main)]} {
frame .bleft -width $geometry(botwidth)
} else {
frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
}
frame .bleft.top
frame .bleft.mid
button .bleft.top.search -text [mc "Search"] -command dosearch
pack .bleft.top.search -side left -padx 5
set sstring .bleft.top.sstring
entry $sstring -width 20 -font textfont -textvariable searchstring
lappend entries $sstring
trace add variable searchstring write incrsearch
pack $sstring -side left -expand 1 -fill x
radiobutton .bleft.mid.diff -text [mc "Diff"] \
-command changediffdisp -variable diffelide -value {0 0}
radiobutton .bleft.mid.old -text [mc "Old version"] \
-command changediffdisp -variable diffelide -value {0 1}
radiobutton .bleft.mid.new -text [mc "New version"] \
-command changediffdisp -variable diffelide -value {1 0}
label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
spinbox .bleft.mid.diffcontext -width 5 -font textfont \
-from 1 -increment 1 -to 10000000 \
-validate all -validatecommand "diffcontextvalidate %P" \
-textvariable diffcontextstring
.bleft.mid.diffcontext set $diffcontext
trace add variable diffcontextstring write diffcontextchange
lappend entries .bleft.mid.diffcontext
pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
set ctext .bleft.ctext
text $ctext -background $bgcolor -foreground $fgcolor \
-state disabled -font textfont \
-yscrollcommand scrolltext -wrap none
if {$have_tk85} {
$ctext conf -tabstyle wordprocessor
}
scrollbar .bleft.sb -command "$ctext yview"
pack .bleft.top -side top -fill x
pack .bleft.mid -side top -fill x
pack .bleft.sb -side right -fill y
pack $ctext -side left -fill both -expand 1
lappend bglist $ctext
lappend fglist $ctext
$ctext tag conf comment -wrap $wrapcomment
$ctext tag conf filesep -font textfontbold -back "#aaaaaa"
$ctext tag conf hunksep -fore [lindex $diffcolors 2]
$ctext tag conf d0 -fore [lindex $diffcolors 0]
$ctext tag conf d1 -fore [lindex $diffcolors 1]
$ctext tag conf m0 -fore red
$ctext tag conf m1 -fore blue
$ctext tag conf m2 -fore green
$ctext tag conf m3 -fore purple
$ctext tag conf m4 -fore brown
$ctext tag conf m5 -fore "#009090"
$ctext tag conf m6 -fore magenta
$ctext tag conf m7 -fore "#808000"
$ctext tag conf m8 -fore "#009000"
$ctext tag conf m9 -fore "#ff0080"
$ctext tag conf m10 -fore cyan
$ctext tag conf m11 -fore "#b07070"
$ctext tag conf m12 -fore "#70b0f0"
$ctext tag conf m13 -fore "#70f0b0"
$ctext tag conf m14 -fore "#f0b070"
$ctext tag conf m15 -fore "#ff70b0"
$ctext tag conf mmax -fore darkgrey
set mergemax 16
$ctext tag conf mresult -font textfontbold
$ctext tag conf msep -font textfontbold
$ctext tag conf found -back yellow
.pwbottom add .bleft
.pwbottom paneconfigure .bleft -width $geometry(botwidth)
# lower right
frame .bright
frame .bright.mode
radiobutton .bright.mode.patch -text [mc "Patch"] \
-command reselectline -variable cmitmode -value "patch"
radiobutton .bright.mode.tree -text [mc "Tree"] \
-command reselectline -variable cmitmode -value "tree"
grid .bright.mode.patch .bright.mode.tree -sticky ew
pack .bright.mode -side top -fill x
set cflist .bright.cfiles
set indent [font measure mainfont "nn"]
text $cflist \
-selectbackground $selectbgcolor \
-background $bgcolor -foreground $fgcolor \
-font mainfont \
-tabs [list $indent [expr {2 * $indent}]] \
-yscrollcommand ".bright.sb set" \
-cursor [. cget -cursor] \
-spacing1 1 -spacing3 1
lappend bglist $cflist
lappend fglist $cflist
scrollbar .bright.sb -command "$cflist yview"
pack .bright.sb -side right -fill y
pack $cflist -side left -fill both -expand 1
$cflist tag configure highlight \
-background [$cflist cget -selectbackground]
$cflist tag configure bold -font mainfontbold
.pwbottom add .bright
.ctop add .pwbottom
# restore window position if known
if {[info exists geometry(main)]} {
wm geometry . "$geometry(main)"
}
if {[tk windowingsystem] eq {aqua}} {
set M1B M1
} else {
set M1B Control
}
bind .pwbottom <Configure> {resizecdetpanes %W %w}
pack .ctop -fill both -expand 1
bindall <1> {selcanvline %W %x %y}
#bindall <B1-Motion> {selcanvline %W %x %y}
if {[tk windowingsystem] == "win32"} {
bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
} else {
bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
if {[tk windowingsystem] eq "aqua"} {
bindall <MouseWheel> {
set delta [expr {- (%D)}]
allcanvs yview scroll $delta units
}
}
}
bindall <2> "canvscan mark %W %x %y"
bindall <B2-Motion> "canvscan dragto %W %x %y"
bindkey <Home> selfirstline
bindkey <End> sellastline
bind . <Key-Up> "selnextline -1"
bind . <Key-Down> "selnextline 1"
bind . <Shift-Key-Up> "dofind -1 0"
bind . <Shift-Key-Down> "dofind 1 0"
bindkey <Key-Right> "goforw"
bindkey <Key-Left> "goback"
bind . <Key-Prior> "selnextpage -1"
bind . <Key-Next> "selnextpage 1"
bind . <$M1B-Home> "allcanvs yview moveto 0.0"
bind . <$M1B-End> "allcanvs yview moveto 1.0"
bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
bindkey <Key-Delete> "$ctext yview scroll -1 pages"
bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
bindkey <Key-space> "$ctext yview scroll 1 pages"
bindkey p "selnextline -1"
bindkey n "selnextline 1"
bindkey z "goback"
bindkey x "goforw"
bindkey i "selnextline -1"
bindkey k "selnextline 1"
bindkey j "goback"
bindkey l "goforw"
bindkey b "$ctext yview scroll -1 pages"
bindkey d "$ctext yview scroll 18 units"
bindkey u "$ctext yview scroll -18 units"
bindkey / {dofind 1 1}
bindkey <Key-Return> {dofind 1 1}
bindkey ? {dofind -1 1}
bindkey f nextfile
bindkey <F5> updatecommits
bind . <$M1B-q> doquit
bind . <$M1B-f> {dofind 1 1}
bind . <$M1B-g> {dofind 1 0}
bind . <$M1B-r> dosearchback
bind . <$M1B-s> dosearch
bind . <$M1B-equal> {incrfont 1}
bind . <$M1B-plus> {incrfont 1}
bind . <$M1B-KP_Add> {incrfont 1}
bind . <$M1B-minus> {incrfont -1}
bind . <$M1B-KP_Subtract> {incrfont -1}
wm protocol . WM_DELETE_WINDOW doquit
bind . <Button-1> "click %W"
bind $fstring <Key-Return> {dofind 1 1}
bind $sha1entry <Key-Return> gotocommit
bind $sha1entry <<PasteSelection>> clearsha1
bind $cflist <1> {sel_flist %W %x %y; break}
bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
set maincursor [. cget -cursor]
set textcursor [$ctext cget -cursor]
set curtextcursor $textcursor
set rowctxmenu .rowctxmenu
menu $rowctxmenu -tearoff 0
$rowctxmenu add command -label [mc "Diff this -> selected"] \
-command {diffvssel 0}
$rowctxmenu add command -label [mc "Diff selected -> this"] \
-command {diffvssel 1}
$rowctxmenu add command -label [mc "Make patch"] -command mkpatch
$rowctxmenu add command -label [mc "Create tag"] -command mktag
$rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
$rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
$rowctxmenu add command -label [mc "Cherry-pick this commit"] \
-command cherrypick
$rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
-command resethead
set fakerowmenu .fakerowmenu
menu $fakerowmenu -tearoff 0
$fakerowmenu add command -label [mc "Diff this -> selected"] \
-command {diffvssel 0}
$fakerowmenu add command -label [mc "Diff selected -> this"] \
-command {diffvssel 1}
$fakerowmenu add command -label [mc "Make patch"] -command mkpatch
# $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
# $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
# $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
set headctxmenu .headctxmenu
menu $headctxmenu -tearoff 0
$headctxmenu add command -label [mc "Check out this branch"] \
-command cobranch
$headctxmenu add command -label [mc "Remove this branch"] \
-command rmbranch
global flist_menu
set flist_menu .flistctxmenu
menu $flist_menu -tearoff 0
$flist_menu add command -label [mc "Highlight this too"] \
-command {flist_hl 0}
$flist_menu add command -label [mc "Highlight this only"] \
-command {flist_hl 1}
}
# Windows sends all mouse wheel events to the current focused window, not
# the one where the mouse hovers, so bind those events here and redirect
# to the correct window
proc windows_mousewheel_redirector {W X Y D} {
global canv canv2 canv3
set w [winfo containing -displayof $W $X $Y]
if {$w ne ""} {
set u [expr {$D < 0 ? 5 : -5}]
if {$w == $canv || $w == $canv2 || $w == $canv3} {
allcanvs yview scroll $u units
} else {
catch {
$w yview scroll $u units
}
}
}
}
# mouse-2 makes all windows scan vertically, but only the one
# the cursor is in scans horizontally
proc canvscan {op w x y} {
global canv canv2 canv3
foreach c [list $canv $canv2 $canv3] {
if {$c == $w} {
$c scan $op $x $y
} else {
$c scan $op 0 $y
}
}
}
proc scrollcanv {cscroll f0 f1} {
$cscroll set $f0 $f1
drawfrac $f0 $f1
flushhighlights
}
# when we make a key binding for the toplevel, make sure
# it doesn't get triggered when that key is pressed in the
# find string entry widget.
proc bindkey {ev script} {
global entries
bind . $ev $script
set escript [bind Entry $ev]
if {$escript == {}} {
set escript [bind Entry <Key>]
}
foreach e $entries {
bind $e $ev "$escript; break"
}
}
# set the focus back to the toplevel for any click outside
# the entry widgets
proc click {w} {
global ctext entries
foreach e [concat $entries $ctext] {
if {$w == $e} return
}
focus .
}
# Adjust the progress bar for a change in requested extent or canvas size
proc adjustprogress {} {
global progresscanv progressitem progresscoords
global fprogitem fprogcoord lastprogupdate progupdatepending
global rprogitem rprogcoord
set w [expr {[winfo width $progresscanv] - 4}]
set x0 [expr {$w * [lindex $progresscoords 0]}]
set x1 [expr {$w * [lindex $progresscoords 1]}]
set h [winfo height $progresscanv]
$progresscanv coords $progressitem $x0 0 $x1 $h
$progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
$progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
set now [clock clicks -milliseconds]
if {$now >= $lastprogupdate + 100} {
set progupdatepending 0
update
} elseif {!$progupdatepending} {
set progupdatepending 1
after [expr {$lastprogupdate + 100 - $now}] doprogupdate
}
}
proc doprogupdate {} {
global lastprogupdate progupdatepending
if {$progupdatepending} {
set progupdatepending 0
set lastprogupdate [clock clicks -milliseconds]
update
}
}
proc savestuff {w} {
global canv canv2 canv3 mainfont textfont uifont tabstop
global stuffsaved findmergefiles maxgraphpct
global maxwidth showneartags showlocalchanges
global viewname viewfiles viewargs viewperm nextviewnum
global cmitmode wrapcomment datetimeformat limitdiffs
global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
if {$stuffsaved} return
if {![winfo viewable .]} return
catch {
set f [open "~/.gitk-new" w]
puts $f [list set mainfont $mainfont]
puts $f [list set textfont $textfont]
puts $f [list set uifont $uifont]
puts $f [list set tabstop $tabstop]
puts $f [list set findmergefiles $findmergefiles]
puts $f [list set maxgraphpct $maxgraphpct]
puts $f [list set maxwidth $maxwidth]
puts $f [list set cmitmode $cmitmode]
puts $f [list set wrapcomment $wrapcomment]
puts $f [list set showneartags $showneartags]
puts $f [list set showlocalchanges $showlocalchanges]
puts $f [list set datetimeformat $datetimeformat]
puts $f [list set limitdiffs $limitdiffs]
puts $f [list set bgcolor $bgcolor]
puts $f [list set fgcolor $fgcolor]
puts $f [list set colors $colors]
puts $f [list set diffcolors $diffcolors]
puts $f [list set diffcontext $diffcontext]
puts $f [list set selectbgcolor $selectbgcolor]
puts $f "set geometry(main) [wm geometry .]"
puts $f "set geometry(topwidth) [winfo width .tf]"
puts $f "set geometry(topheight) [winfo height .tf]"
puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
puts $f "set geometry(botwidth) [winfo width .bleft]"
puts $f "set geometry(botheight) [winfo height .bleft]"
puts -nonewline $f "set permviews {"
for {set v 0} {$v < $nextviewnum} {incr v} {
if {$viewperm($v)} {
puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
}
}
puts $f "}"
close $f
file rename -force "~/.gitk-new" "~/.gitk"
}
set stuffsaved 1
}
proc resizeclistpanes {win w} {
global oldwidth
if {[info exists oldwidth($win)]} {
set s0 [$win sash coord 0]
set s1 [$win sash coord 1]
if {$w < 60} {
set sash0 [expr {int($w/2 - 2)}]
set sash1 [expr {int($w*5/6 - 2)}]
} else {
set factor [expr {1.0 * $w / $oldwidth($win)}]
set sash0 [expr {int($factor * [lindex $s0 0])}]
set sash1 [expr {int($factor * [lindex $s1 0])}]
if {$sash0 < 30} {
set sash0 30
}
if {$sash1 < $sash0 + 20} {
set sash1 [expr {$sash0 + 20}]
}
if {$sash1 > $w - 10} {
set sash1 [expr {$w - 10}]
if {$sash0 > $sash1 - 20} {
set sash0 [expr {$sash1 - 20}]
}
}
}
$win sash place 0 $sash0 [lindex $s0 1]
$win sash place 1 $sash1 [lindex $s1 1]
}
set oldwidth($win) $w
}
proc resizecdetpanes {win w} {
global oldwidth
if {[info exists oldwidth($win)]} {
set s0 [$win sash coord 0]
if {$w < 60} {
set sash0 [expr {int($w*3/4 - 2)}]
} else {
set factor [expr {1.0 * $w / $oldwidth($win)}]
set sash0 [expr {int($factor * [lindex $s0 0])}]
if {$sash0 < 45} {
set sash0 45
}
if {$sash0 > $w - 15} {
set sash0 [expr {$w - 15}]
}
}
$win sash place 0 $sash0 [lindex $s0 1]
}
set oldwidth($win) $w
}
proc allcanvs args {
global canv canv2 canv3
eval $canv $args
eval $canv2 $args
eval $canv3 $args
}
proc bindall {event action} {
global canv canv2 canv3
bind $canv $event $action
bind $canv2 $event $action
bind $canv3 $event $action
}
proc about {} {
global uifont
set w .about
if {[winfo exists $w]} {
raise $w
return
}
toplevel $w
wm title $w [mc "About gitk"]
message $w.m -text [mc "
Gitk - a commit viewer for git
Copyright © 2005-2006 Paul Mackerras
Use and redistribute under the terms of the GNU General Public License"] \
-justify center -aspect 400 -border 2 -bg white -relief groove
pack $w.m -side top -fill x -padx 2 -pady 2
button $w.ok -text [mc "Close"] -command "destroy $w" -default active
pack $w.ok -side bottom
bind $w <Visibility> "focus $w.ok"
bind $w <Key-Escape> "destroy $w"
bind $w <Key-Return> "destroy $w"
}
proc keys {} {
set w .keys
if {[winfo exists $w]} {
raise $w
return
}
if {[tk windowingsystem] eq {aqua}} {
set M1T Cmd
} else {
set M1T Ctrl
}
toplevel $w
wm title $w [mc "Gitk key bindings"]
message $w.m -text [mc "
Gitk key bindings:
<$M1T-Q> Quit
<Home> Move to first commit
<End> Move to last commit
<Up>, p, i Move up one commit
<Down>, n, k Move down one commit
<Left>, z, j Go back in history list
<Right>, x, l Go forward in history list
<PageUp> Move up one page in commit list
<PageDown> Move down one page in commit list
<$M1T-Home> Scroll to top of commit list
<$M1T-End> Scroll to bottom of commit list
<$M1T-Up> Scroll commit list up one line
<$M1T-Down> Scroll commit list down one line
<$M1T-PageUp> Scroll commit list up one page
<$M1T-PageDown> Scroll commit list down one page
<Shift-Up> Find backwards (upwards, later commits)
<Shift-Down> Find forwards (downwards, earlier commits)
<Delete>, b Scroll diff view up one page
<Backspace> Scroll diff view up one page
<Space> Scroll diff view down one page
u Scroll diff view up 18 lines
d Scroll diff view down 18 lines
<$M1T-F> Find
<$M1T-G> Move to next find hit
<Return> Move to next find hit
/ Move to next find hit, or redo find
? Move to previous find hit
f Scroll diff view to next file
<$M1T-S> Search for next hit in diff view
<$M1T-R> Search for previous hit in diff view
<$M1T-KP+> Increase font size
<$M1T-plus> Increase font size
<$M1T-KP-> Decrease font size
<$M1T-minus> Decrease font size
<F5> Update
"] \
-justify left -bg white -border 2 -relief groove
pack $w.m -side top -fill both -padx 2 -pady 2
button $w.ok -text [mc "Close"] -command "destroy $w" -default active
pack $w.ok -side bottom
bind $w <Visibility> "focus $w.ok"
bind $w <Key-Escape> "destroy $w"
bind $w <Key-Return> "destroy $w"
}
# Procedures for manipulating the file list window at the
# bottom right of the overall window.
proc treeview {w l openlevs} {
global treecontents treediropen treeheight treeparent treeindex
set ix 0
set treeindex() 0
set lev 0
set prefix {}
set prefixend -1
set prefendstack {}
set htstack {}
set ht 0
set treecontents() {}
$w conf -state normal
foreach f $l {
while {[string range $f 0 $prefixend] ne $prefix} {
if {$lev <= $openlevs} {
$w mark set e:$treeindex($prefix) "end -1c"
$w mark gravity e:$treeindex($prefix) left
}
set treeheight($prefix) $ht
incr ht [lindex $htstack end]
set htstack [lreplace $htstack end end]
set prefixend [lindex $prefendstack end]
set prefendstack [lreplace $prefendstack end end]
set prefix [string range $prefix 0 $prefixend]
incr lev -1
}
set tail [string range $f [expr {$prefixend+1}] end]
while {[set slash [string first "/" $tail]] >= 0} {
lappend htstack $ht
set ht 0
lappend prefendstack $prefixend
incr prefixend [expr {$slash + 1}]
set d [string range $tail 0 $slash]
lappend treecontents($prefix) $d
set oldprefix $prefix
append prefix $d
set treecontents($prefix) {}
set treeindex($prefix) [incr ix]
set treeparent($prefix) $oldprefix
set tail [string range $tail [expr {$slash+1}] end]
if {$lev <= $openlevs} {
set ht 1
set treediropen($prefix) [expr {$lev < $openlevs}]
set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
$w mark set d:$ix "end -1c"
$w mark gravity d:$ix left
set str "\n"
for {set i 0} {$i < $lev} {incr i} {append str "\t"}
$w insert end $str
$w image create end -align center -image $bm -padx 1 \
-name a:$ix
$w insert end $d [highlight_tag $prefix]
$w mark set s:$ix "end -1c"
$w mark gravity s:$ix left
}
incr lev
}
if {$tail ne {}} {
if {$lev <= $openlevs} {
incr ht
set str "\n"
for {set i 0} {$i < $lev} {incr i} {append str "\t"}
$w insert end $str
$w insert end $tail [highlight_tag $f]
}
lappend treecontents($prefix) $tail
}
}
while {$htstack ne {}} {
set treeheight($prefix) $ht
incr ht [lindex $htstack end]
set htstack [lreplace $htstack end end]
set prefixend [lindex $prefendstack end]
set prefendstack [lreplace $prefendstack end end]
set prefix [string range $prefix 0 $prefixend]
}
$w conf -state disabled
}
proc linetoelt {l} {
global treeheight treecontents
set y 2
set prefix {}
while {1} {
foreach e $treecontents($prefix) {
if {$y == $l} {
return "$prefix$e"
}
set n 1
if {[string index $e end] eq "/"} {
set n $treeheight($prefix$e)
if {$y + $n > $l} {
append prefix $e
incr y
break
}
}
incr y $n
}
}
}
proc highlight_tree {y prefix} {
global treeheight treecontents cflist
foreach e $treecontents($prefix) {
set path $prefix$e
if {[highlight_tag $path] ne {}} {
$cflist tag add bold $y.0 "$y.0 lineend"
}
incr y
if {[string index $e end] eq "/" && $treeheight($path) > 1} {
set y [highlight_tree $y $path]
}
}
return $y
}
proc treeclosedir {w dir} {
global treediropen treeheight treeparent treeindex
set ix $treeindex($dir)
$w conf -state normal
$w delete s:$ix e:$ix
set treediropen($dir) 0
$w image configure a:$ix -image tri-rt
$w conf -state disabled
set n [expr {1 - $treeheight($dir)}]
while {$dir ne {}} {
incr treeheight($dir) $n
set dir $treeparent($dir)
}
}
proc treeopendir {w dir} {
global treediropen treeheight treeparent treecontents treeindex
set ix $treeindex($dir)
$w conf -state normal
$w image configure a:$ix -image tri-dn
$w mark set e:$ix s:$ix
$w mark gravity e:$ix right
set lev 0
set str "\n"
set n [llength $treecontents($dir)]
for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
incr lev
append str "\t"
incr treeheight($x) $n
}
foreach e $treecontents($dir) {
set de $dir$e
if {[string index $e end] eq "/"} {
set iy $treeindex($de)
$w mark set d:$iy e:$ix
$w mark gravity d:$iy left
$w insert e:$ix $str
set treediropen($de) 0
$w image create e:$ix -align center -image tri-rt -padx 1 \
-name a:$iy
$w insert e:$ix $e [highlight_tag $de]
$w mark set s:$iy e:$ix
$w mark gravity s:$iy left
set treeheight($de) 1
} else {
$w insert e:$ix $str
$w insert e:$ix $e [highlight_tag $de]
}
}
$w mark gravity e:$ix left
$w conf -state disabled
set treediropen($dir) 1
set top [lindex [split [$w index @0,0] .] 0]
set ht [$w cget -height]
set l [lindex [split [$w index s:$ix] .] 0]
if {$l < $top} {
$w yview $l.0
} elseif {$l + $n + 1 > $top + $ht} {
set top [expr {$l + $n + 2 - $ht}]
if {$l < $top} {
set top $l
}
$w yview $top.0
}
}
proc treeclick {w x y} {
global treediropen cmitmode ctext cflist cflist_top
if {$cmitmode ne "tree"} return
if {![info exists cflist_top]} return
set l [lindex [split [$w index "@$x,$y"] "."] 0]
$cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
$cflist tag add highlight $l.0 "$l.0 lineend"
set cflist_top $l
if {$l == 1} {
$ctext yview 1.0
return
}
set e [linetoelt $l]
if {[string index $e end] ne "/"} {
showfile $e
} elseif {$treediropen($e)} {
treeclosedir $w $e
} else {
treeopendir $w $e
}
}
proc setfilelist {id} {
global treefilelist cflist
treeview $cflist $treefilelist($id) 0
}
image create bitmap tri-rt -background black -foreground blue -data {
#define tri-rt_width 13
#define tri-rt_height 13
static unsigned char tri-rt_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
0x00, 0x00};
} -maskdata {
#define tri-rt-mask_width 13
#define tri-rt-mask_height 13
static unsigned char tri-rt-mask_bits[] = {
0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
0x08, 0x00};
}
image create bitmap tri-dn -background black -foreground blue -data {
#define tri-dn_width 13
#define tri-dn_height 13
static unsigned char tri-dn_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00};
} -maskdata {
#define tri-dn-mask_width 13
#define tri-dn-mask_height 13
static unsigned char tri-dn-mask_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00};
}
image create bitmap reficon-T -background black -foreground yellow -data {
#define tagicon_width 13
#define tagicon_height 9
static unsigned char tagicon_bits[] = {
0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
} -maskdata {
#define tagicon-mask_width 13
#define tagicon-mask_height 9
static unsigned char tagicon-mask_bits[] = {
0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
}
set rectdata {
#define headicon_width 13
#define headicon_height 9
static unsigned char headicon_bits[] = {
0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
}
set rectmask {
#define headicon-mask_width 13
#define headicon-mask_height 9
static unsigned char headicon-mask_bits[] = {
0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
}
image create bitmap reficon-H -background black -foreground green \
-data $rectdata -maskdata $rectmask
image create bitmap reficon-o -background black -foreground "#ddddff" \
-data $rectdata -maskdata $rectmask
proc init_flist {first} {
global cflist cflist_top selectedline difffilestart
$cflist conf -state normal
$cflist delete 0.0 end
if {$first ne {}} {
$cflist insert end $first
set cflist_top 1
$cflist tag add highlight 1.0 "1.0 lineend"
} else {
catch {unset cflist_top}
}
$cflist conf -state disabled
set difffilestart {}
}
proc highlight_tag {f} {
global highlight_paths
foreach p $highlight_paths {
if {[string match $p $f]} {
return "bold"
}
}
return {}
}
proc highlight_filelist {} {
global cmitmode cflist
$cflist conf -state normal
if {$cmitmode ne "tree"} {
set end [lindex [split [$cflist index end] .] 0]
for {set l 2} {$l < $end} {incr l} {
set line [$cflist get $l.0 "$l.0 lineend"]
if {[highlight_tag $line] ne {}} {
$cflist tag add bold $l.0 "$l.0 lineend"
}
}
} else {
highlight_tree 2 {}
}
$cflist conf -state disabled
}
proc unhighlight_filelist {} {
global cflist
$cflist conf -state normal
$cflist tag remove bold 1.0 end
$cflist conf -state disabled
}
proc add_flist {fl} {
global cflist
$cflist conf -state normal
foreach f $fl {
$cflist insert end "\n"
$cflist insert end $f [highlight_tag $f]
}
$cflist conf -state disabled
}
proc sel_flist {w x y} {
global ctext difffilestart cflist cflist_top cmitmode
if {$cmitmode eq "tree"} return
if {![info exists cflist_top]} return
set l [lindex [split [$w index "@$x,$y"] "."] 0]
$cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
$cflist tag add highlight $l.0 "$l.0 lineend"
set cflist_top $l
if {$l == 1} {
$ctext yview 1.0
} else {
catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
}
}
proc pop_flist_menu {w X Y x y} {
global ctext cflist cmitmode flist_menu flist_menu_file
global treediffs diffids
stopfinding
set l [lindex [split [$w index "@$x,$y"] "."] 0]
if {$l <= 1} return
if {$cmitmode eq "tree"} {
set e [linetoelt $l]
if {[string index $e end] eq "/"} return
} else {
set e [lindex $treediffs($diffids) [expr {$l-2}]]
}
set flist_menu_file $e
tk_popup $flist_menu $X $Y
}
proc flist_hl {only} {
global flist_menu_file findstring gdttype
set x [shellquote $flist_menu_file]
if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
set findstring $x
} else {
append findstring " " $x
}
set gdttype [mc "touching paths:"]
}
# Functions for adding and removing shell-type quoting
proc shellquote {str} {
if {![string match "*\['\"\\ \t]*" $str]} {
return $str
}
if {![string match "*\['\"\\]*" $str]} {
return "\"$str\""
}
if {![string match "*'*" $str]} {
return "'$str'"
}
return "\"[string map {\" \\\" \\ \\\\} $str]\""
}
proc shellarglist {l} {
set str {}
foreach a $l {
if {$str ne {}} {
append str " "
}
append str [shellquote $a]
}
return $str
}
proc shelldequote {str} {
set ret {}
set used -1
while {1} {
incr used
if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
append ret [string range $str $used end]
set used [string length $str]
break
}
set first [lindex $first 0]
set ch [string index $str $first]
if {$first > $used} {
append ret [string range $str $used [expr {$first - 1}]]
set used $first
}
if {$ch eq " " || $ch eq "\t"} break
incr used
if {$ch eq "'"} {
set first [string first "'" $str $used]
if {$first < 0} {
error "unmatched single-quote"
}
append ret [string range $str $used [expr {$first - 1}]]
set used $first
continue
}
if {$ch eq "\\"} {
if {$used >= [string length $str]} {
error "trailing backslash"
}
append ret [string index $str $used]
continue
}
# here ch == "\""
while {1} {
if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
error "unmatched double-quote"
}
set first [lindex $first 0]
set ch [string index $str $first]
if {$first > $used} {
append ret [string range $str $used [expr {$first - 1}]]
set used $first
}
if {$ch eq "\""} break
incr used
append ret [string index $str $used]
incr used
}
}
return [list $used $ret]
}
proc shellsplit {str} {
set l {}
while {1} {
set str [string trimleft $str]
if {$str eq {}} break
set dq [shelldequote $str]
set n [lindex $dq 0]
set word [lindex $dq 1]
set str [string range $str $n end]
lappend l $word
}
return $l
}
# Code to implement multiple views
proc newview {ishighlight} {
global nextviewnum newviewname newviewperm newishighlight
global newviewargs revtreeargs
set newishighlight $ishighlight
set top .gitkview
if {[winfo exists $top]} {
raise $top
return
}
set newviewname($nextviewnum) "View $nextviewnum"
set newviewperm($nextviewnum) 0
set newviewargs($nextviewnum) [shellarglist $revtreeargs]
vieweditor $top $nextviewnum [mc "Gitk view definition"]
}
proc editview {} {
global curview
global viewname viewperm newviewname newviewperm
global viewargs newviewargs
set top .gitkvedit-$curview
if {[winfo exists $top]} {
raise $top
return
}
set newviewname($curview) $viewname($curview)
set newviewperm($curview) $viewperm($curview)
set newviewargs($curview) [shellarglist $viewargs($curview)]
vieweditor $top $curview "Gitk: edit view $viewname($curview)"
}
proc vieweditor {top n title} {
global newviewname newviewperm viewfiles bgcolor
toplevel $top
wm title $top $title
label $top.nl -text [mc "Name"]
entry $top.name -width 20 -textvariable newviewname($n)
grid $top.nl $top.name -sticky w -pady 5
checkbutton $top.perm -text [mc "Remember this view"] \
-variable newviewperm($n)
grid $top.perm - -pady 5 -sticky w
message $top.al -aspect 1000 \
-text [mc "Commits to include (arguments to git rev-list):"]
grid $top.al - -sticky w -pady 5
entry $top.args -width 50 -textvariable newviewargs($n) \
-background $bgcolor
grid $top.args - -sticky ew -padx 5
message $top.l -aspect 1000 \
-text [mc "Enter files and directories to include, one per line:"]
grid $top.l - -sticky w
text $top.t -width 40 -height 10 -background $bgcolor -font uifont
if {[info exists viewfiles($n)]} {
foreach f $viewfiles($n) {
$top.t insert end $f
$top.t insert end "\n"
}
$top.t delete {end - 1c} end
$top.t mark set insert 0.0
}
grid $top.t - -sticky ew -padx 5
frame $top.buts
button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
grid $top.buts.ok $top.buts.can
grid columnconfigure $top.buts 0 -weight 1 -uniform a
grid columnconfigure $top.buts 1 -weight 1 -uniform a
grid $top.buts - -pady 10 -sticky ew
focus $top.t
}
proc doviewmenu {m first cmd op argv} {
set nmenu [$m index end]
for {set i $first} {$i <= $nmenu} {incr i} {
if {[$m entrycget $i -command] eq $cmd} {
eval $m $op $i $argv
break
}
}
}
proc allviewmenus {n op args} {
# global viewhlmenu
doviewmenu .bar.view 5 [list showview $n] $op $args
# doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
}
proc newviewok {top n} {
global nextviewnum newviewperm newviewname newishighlight
global viewname viewfiles viewperm selectedview curview
global viewargs newviewargs viewhlmenu
if {[catch {
set newargs [shellsplit $newviewargs($n)]
} err]} {
error_popup "[mc "Error in commit selection arguments:"] $err"
wm raise $top
focus $top
return
}
set files {}
foreach f [split [$top.t get 0.0 end] "\n"] {
set ft [string trim $f]
if {$ft ne {}} {
lappend files $ft
}
}
if {![info exists viewfiles($n)]} {
# creating a new view
incr nextviewnum
set viewname($n) $newviewname($n)
set viewperm($n) $newviewperm($n)
set viewfiles($n) $files
set viewargs($n) $newargs
addviewmenu $n
if {!$newishighlight} {
run showview $n
} else {
run addvhighlight $n
}
} else {
# editing an existing view
set viewperm($n) $newviewperm($n)
if {$newviewname($n) ne $viewname($n)} {
set viewname($n) $newviewname($n)
doviewmenu .bar.view 5 [list showview $n] \
entryconf [list -label $viewname($n)]
# doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
# entryconf [list -label $viewname($n) -value $viewname($n)]
}
if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
set viewfiles($n) $files
set viewargs($n) $newargs
if {$curview == $n} {
run updatecommits
}
}
}
catch {destroy $top}
}
proc delview {} {
global curview viewdata viewperm hlview selectedhlview
if {$curview == 0} return
if {[info exists hlview] && $hlview == $curview} {
set selectedhlview [mc "None"]
unset hlview
}
allviewmenus $curview delete
set viewdata($curview) {}
set viewperm($curview) 0
showview 0
}
proc addviewmenu {n} {
global viewname viewhlmenu
.bar.view add radiobutton -label $viewname($n) \
-command [list showview $n] -variable selectedview -value $n
#$viewhlmenu add radiobutton -label $viewname($n) \
# -command [list addvhighlight $n] -variable selectedhlview
}
proc flatten {var} {
global $var
set ret {}
foreach i [array names $var] {
lappend ret $i [set $var\($i\)]
}
return $ret
}
proc unflatten {var l} {
global $var
catch {unset $var}
foreach {i v} $l {
set $var\($i\) $v
}
}
proc showview {n} {
global curview viewdata viewfiles
global displayorder parentlist rowidlist rowisopt rowfinal
global colormap rowtextx commitrow nextcolor canvxmax
global numcommits commitlisted
global selectedline currentid canv canvy0
global treediffs
global pending_select phase
global commitidx
global commfd
global selectedview selectfirst
global vparentlist vdisporder vcmitlisted
global hlview selectedhlview commitinterest
if {$n == $curview} return
set selid {}
if {[info exists selectedline]} {
set selid $currentid
set y [yc $selectedline]
set ymax [lindex [$canv cget -scrollregion] 3]
set span [$canv yview]
set ytop [expr {[lindex $span 0] * $ymax}]
set ybot [expr {[lindex $span 1] * $ymax}]
if {$ytop < $y && $y < $ybot} {
set yscreen [expr {$y - $ytop}]
} else {
set yscreen [expr {($ybot - $ytop) / 2}]
}
} elseif {[info exists pending_select]} {
set selid $pending_select
unset pending_select
}
unselectline
normalline
if {$curview >= 0} {
set vparentlist($curview) $parentlist
set vdisporder($curview) $displayorder
set vcmitlisted($curview) $commitlisted
if {$phase ne {} ||
![info exists viewdata($curview)] ||
[lindex $viewdata($curview) 0] ne {}} {
set viewdata($curview) \
[list $phase $rowidlist $rowisopt $rowfinal]
}
}
catch {unset treediffs}
clear_display
if {[info exists hlview] && $hlview == $n} {
unset hlview
set selectedhlview [mc "None"]
}
catch {unset commitinterest}
set curview $n
set selectedview $n
.bar.view entryconf [mc "Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
.bar.view entryconf [mc "Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
run refill_reflist
if {![info exists viewdata($n)]} {
if {$selid ne {}} {
set pending_select $selid
}
getcommits
return
}
set v $viewdata($n)
set phase [lindex $v 0]
set displayorder $vdisporder($n)
set parentlist $vparentlist($n)
set commitlisted $vcmitlisted($n)
set rowidlist [lindex $v 1]
set rowisopt [lindex $v 2]
set rowfinal [lindex $v 3]
set numcommits $commitidx($n)
catch {unset colormap}
catch {unset rowtextx}
set nextcolor 0
set canvxmax [$canv cget -width]
set curview $n
set row 0
setcanvscroll
set yf 0
set row {}
set selectfirst 0
if {$selid ne {} && [info exists commitrow($n,$selid)]} {
set row $commitrow($n,$selid)
# try to get the selected row in the same position on the screen
set ymax [lindex [$canv cget -scrollregion] 3]
set ytop [expr {[yc $row] - $yscreen}]
if {$ytop < 0} {
set ytop 0
}
set yf [expr {$ytop * 1.0 / $ymax}]
}
allcanvs yview moveto $yf
drawvisible
if {$row ne {}} {
selectline $row 0
} elseif {$selid ne {}} {
set pending_select $selid
} else {
set row [first_real_row]
if {$row < $numcommits} {
selectline $row 0
} else {
set selectfirst 1
}
}
if {$phase ne {}} {
if {$phase eq "getcommits"} {
show_status [mc "Reading commits..."]
}
run chewcommits $n
} elseif {$numcommits == 0} {
show_status [mc "No commits selected"]
}
}
# Stuff relating to the highlighting facility
proc ishighlighted {row} {
global vhighlights fhighlights nhighlights rhighlights
if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
return $nhighlights($row)
}
if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
return $vhighlights($row)
}
if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
return $fhighlights($row)
}
if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
return $rhighlights($row)
}
return 0
}
proc bolden {row font} {
global canv linehtag selectedline boldrows
lappend boldrows $row
$canv itemconf $linehtag($row) -font $font
if {[info exists selectedline] && $row == $selectedline} {
$canv delete secsel
set t [eval $canv create rect [$canv bbox $linehtag($row)] \
-outline {{}} -tags secsel \
-fill [$canv cget -selectbackground]]
$canv lower $t
}
}
proc bolden_name {row font} {
global canv2 linentag selectedline boldnamerows
lappend boldnamerows $row
$canv2 itemconf $linentag($row) -font $font
if {[info exists selectedline] && $row == $selectedline} {
$canv2 delete secsel
set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
-outline {{}} -tags secsel \
-fill [$canv2 cget -selectbackground]]
$canv2 lower $t
}
}
proc unbolden {} {
global boldrows
set stillbold {}
foreach row $boldrows {
if {![ishighlighted $row]} {
bolden $row mainfont
} else {
lappend stillbold $row
}
}
set boldrows $stillbold
}
proc addvhighlight {n} {
global hlview curview viewdata vhl_done vhighlights commitidx
if {[info exists hlview]} {
delvhighlight
}
set hlview $n
if {$n != $curview && ![info exists viewdata($n)]} {
set viewdata($n) [list getcommits {{}} 0 0 0]
set vparentlist($n) {}
set vdisporder($n) {}
set vcmitlisted($n) {}
start_rev_list $n
}
set vhl_done $commitidx($hlview)
if {$vhl_done > 0} {
drawvisible
}
}
proc delvhighlight {} {
global hlview vhighlights
if {![info exists hlview]} return
unset hlview
catch {unset vhighlights}
unbolden
}
proc vhighlightmore {} {
global hlview vhl_done commitidx vhighlights
global displayorder vdisporder curview
set max $commitidx($hlview)
if {$hlview == $curview} {
set disp $displayorder
} else {
set disp $vdisporder($hlview)
}
set vr [visiblerows]
set r0 [lindex $vr 0]
set r1 [lindex $vr 1]
for {set i $vhl_done} {$i < $max} {incr i} {
set id [lindex $disp $i]
if {[info exists commitrow($curview,$id)]} {
set row $commitrow($curview,$id)
if {$r0 <= $row && $row <= $r1} {
if {![highlighted $row]} {
bolden $row mainfontbold
}
set vhighlights($row) 1
}
}
}
set vhl_done $max
}
proc askvhighlight {row id} {
global hlview vhighlights commitrow iddrawn
if {[info exists commitrow($hlview,$id)]} {
if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
bolden $row mainfontbold
}
set vhighlights($row) 1
} else {
set vhighlights($row) 0
}
}
proc hfiles_change {} {
global highlight_files filehighlight fhighlights fh_serial
global highlight_paths gdttype
if {[info exists filehighlight]} {
# delete previous highlights
catch {close $filehighlight}
unset filehighlight
catch {unset fhighlights}
unbolden
unhighlight_filelist
}
set highlight_paths {}
after cancel do_file_hl $fh_serial
incr fh_serial
if {$highlight_files ne {}} {
after 300 do_file_hl $fh_serial
}
}
proc gdttype_change {name ix op} {
global gdttype highlight_files findstring findpattern
stopfinding
if {$findstring ne {}} {
if {$gdttype eq [mc "containing:"]} {
if {$highlight_files ne {}} {
set highlight_files {}
hfiles_change
}
findcom_change
} else {
if {$findpattern ne {}} {
set findpattern {}
findcom_change
}
set highlight_files $findstring
hfiles_change
}
drawvisible
}
# enable/disable findtype/findloc menus too
}
proc find_change {name ix op} {
global gdttype findstring highlight_files
stopfinding
if {$gdttype eq [mc "containing:"]} {
findcom_change
} else {
if {$highlight_files ne $findstring} {
set highlight_files $findstring
hfiles_change
}
}
drawvisible
}
proc findcom_change args {
global nhighlights boldnamerows
global findpattern findtype findstring gdttype
stopfinding
# delete previous highlights, if any
foreach row $boldnamerows {
bolden_name $row mainfont
}
set boldnamerows {}
catch {unset nhighlights}
unbolden
unmarkmatches
if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
set findpattern {}
} elseif {$findtype eq [mc "Regexp"]} {
set findpattern $findstring
} else {
set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
$findstring]
set findpattern "*$e*"
}
}
proc makepatterns {l} {
set ret {}
foreach e $l {
set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
if {[string index $ee end] eq "/"} {
lappend ret "$ee*"
} else {
lappend ret $ee
lappend ret "$ee/*"
}
}
return $ret
}
proc do_file_hl {serial} {
global highlight_files filehighlight highlight_paths gdttype fhl_list
if {$gdttype eq [mc "touching paths:"]} {
if {[catch {set paths [shellsplit $highlight_files]}]} return
set highlight_paths [makepatterns $paths]
highlight_filelist
set gdtargs [concat -- $paths]
} elseif {$gdttype eq [mc "adding/removing string:"]} {
set gdtargs [list "-S$highlight_files"]
} else {
# must be "containing:", i.e. we're searching commit info
return
}
set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
set filehighlight [open $cmd r+]
fconfigure $filehighlight -blocking 0
filerun $filehighlight readfhighlight
set fhl_list {}
drawvisible
flushhighlights
}
proc flushhighlights {} {
global filehighlight fhl_list
if {[info exists filehighlight]} {
lappend fhl_list {}
puts $filehighlight ""
flush $filehighlight
}
}
proc askfilehighlight {row id} {
global filehighlight fhighlights fhl_list
lappend fhl_list $id
set fhighlights($row) -1
puts $filehighlight $id
}
proc readfhighlight {} {
global filehighlight fhighlights commitrow curview iddrawn
global fhl_list find_dirn
if {![info exists filehighlight]} {
return 0
}
set nr 0
while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
set line [string trim $line]
set i [lsearch -exact $fhl_list $line]
if {$i < 0} continue
for {set j 0} {$j < $i} {incr j} {
set id [lindex $fhl_list $j]
if {[info exists commitrow($curview,$id)]} {
set fhighlights($commitrow($curview,$id)) 0
}
}
set fhl_list [lrange $fhl_list [expr {$i+1}] end]
if {$line eq {}} continue
if {![info exists commitrow($curview,$line)]} continue
set row $commitrow($curview,$line)
if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
bolden $row mainfontbold
}
set fhighlights($row) 1
}
if {[eof $filehighlight]} {
# strange...
puts "oops, git diff-tree died"
catch {close $filehighlight}
unset filehighlight
return 0
}
if {[info exists find_dirn]} {
run findmore
}
return 1
}
proc doesmatch {f} {
global findtype findpattern
if {$findtype eq [mc "Regexp"]} {
return [regexp $findpattern $f]
} elseif {$findtype eq [mc "IgnCase"]} {
return [string match -nocase $findpattern $f]
} else {
return [string match $findpattern $f]
}
}
proc askfindhighlight {row id} {
global nhighlights commitinfo iddrawn
global findloc
global markingmatches
if {![info exists commitinfo($id)]} {
getcommit $id
}
set info $commitinfo($id)
set isbold 0
set fldtypes [list [mc Headline] [mc Author] [mc Date] [mc Committer] [mc CDate] [mc Comments]]
foreach f $info ty $fldtypes {
if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
[doesmatch $f]} {
if {$ty eq [mc "Author"]} {
set isbold 2
break
}
set isbold 1
}
}
if {$isbold && [info exists iddrawn($id)]} {
if {![ishighlighted $row]} {
bolden $row mainfontbold
if {$isbold > 1} {
bolden_name $row mainfontbold
}
}
if {$markingmatches} {
markrowmatches $row $id
}
}
set nhighlights($row) $isbold
}
proc markrowmatches {row id} {
global canv canv2 linehtag linentag commitinfo findloc
set headline [lindex $commitinfo($id) 0]
set author [lindex $commitinfo($id) 1]
$canv delete match$row
$canv2 delete match$row
if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
set m [findmatches $headline]
if {$m ne {}} {
markmatches $canv $row $headline $linehtag($row) $m \
[$canv itemcget $linehtag($row) -font] $row
}
}
if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
set m [findmatches $author]
if {$m ne {}} {
markmatches $canv2 $row $author $linentag($row) $m \
[$canv2 itemcget $linentag($row) -font] $row
}
}
}
proc vrel_change {name ix op} {
global highlight_related
rhighlight_none
if {$highlight_related ne [mc "None"]} {
run drawvisible
}
}
# prepare for testing whether commits are descendents or ancestors of a
proc rhighlight_sel {a} {
global descendent desc_todo ancestor anc_todo
global highlight_related rhighlights
catch {unset descendent}
set desc_todo [list $a]
catch {unset ancestor}
set anc_todo [list $a]
if {$highlight_related ne [mc "None"]} {
rhighlight_none
run drawvisible
}
}
proc rhighlight_none {} {
global rhighlights
catch {unset rhighlights}
unbolden
}
proc is_descendent {a} {
global curview children commitrow descendent desc_todo
set v $curview
set la $commitrow($v,$a)
set todo $desc_todo
set leftover {}
set done 0
for {set i 0} {$i < [llength $todo]} {incr i} {
set do [lindex $todo $i]
if {$commitrow($v,$do) < $la} {
lappend leftover $do
continue
}
foreach nk $children($v,$do) {
if {![info exists descendent($nk)]} {
set descendent($nk) 1
lappend todo $nk
if {$nk eq $a} {
set done 1
}
}
}
if {$done} {
set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
return
}
}
set descendent($a) 0
set desc_todo $leftover
}
proc is_ancestor {a} {
global curview parentlist commitrow ancestor anc_todo
set v $curview
set la $commitrow($v,$a)
set todo $anc_todo
set leftover {}
set done 0
for {set i 0} {$i < [llength $todo]} {incr i} {
set do [lindex $todo $i]
if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
lappend leftover $do
continue
}
foreach np [lindex $parentlist $commitrow($v,$do)] {
if {![info exists ancestor($np)]} {
set ancestor($np) 1
lappend todo $np
if {$np eq $a} {
set done 1
}
}
}
if {$done} {
set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
return
}
}
set ancestor($a) 0
set anc_todo $leftover
}
proc askrelhighlight {row id} {
global descendent highlight_related iddrawn rhighlights
global selectedline ancestor
if {![info exists selectedline]} return
set isbold 0
if {$highlight_related eq [mc "Descendant"] ||
$highlight_related eq [mc "Not descendant"]} {
if {![info exists descendent($id)]} {
is_descendent $id
}
if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
set isbold 1
}
} elseif {$highlight_related eq [mc "Ancestor"] ||
$highlight_related eq [mc "Not ancestor"]} {
if {![info exists ancestor($id)]} {
is_ancestor $id
}
if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
set isbold 1
}
}
if {[info exists iddrawn($id)]} {
if {$isbold && ![ishighlighted $row]} {
bolden $row mainfontbold
}
}
set rhighlights($row) $isbold
}
# Graph layout functions
proc shortids {ids} {
set res {}
foreach id $ids {
if {[llength $id] > 1} {
lappend res [shortids $id]
} elseif {[regexp {^[0-9a-f]{40}$} $id]} {
lappend res [string range $id 0 7]
} else {
lappend res $id
}
}
return $res
}
proc ntimes {n o} {
set ret {}
set o [list $o]
for {set mask 1} {$mask <= $n} {incr mask $mask} {
if {($n & $mask) != 0} {
set ret [concat $ret $o]
}
set o [concat $o $o]
}
return $ret
}
# Work out where id should go in idlist so that order-token
# values increase from left to right
proc idcol {idlist id {i 0}} {
global ordertok curview
set t $ordertok($curview,$id)
if {$i >= [llength $idlist] ||
$t < $ordertok($curview,[lindex $idlist $i])} {
if {$i > [llength $idlist]} {
set i [llength $idlist]
}
while {[incr i -1] >= 0 &&
$t < $ordertok($curview,[lindex $idlist $i])} {}
incr i
} else {
if {$t > $ordertok($curview,[lindex $idlist $i])} {
while {[incr i] < [llength $idlist] &&
$t >= $ordertok($curview,[lindex $idlist $i])} {}
}
}
return $i
}
proc initlayout {} {
global rowidlist rowisopt rowfinal displayorder commitlisted
global numcommits canvxmax canv
global nextcolor
global parentlist
global colormap rowtextx
global selectfirst
set numcommits 0
set displayorder {}
set commitlisted {}
set parentlist {}
set nextcolor 0
set rowidlist {}
set rowisopt {}
set rowfinal {}
set canvxmax [$canv cget -width]
catch {unset colormap}
catch {unset rowtextx}
set selectfirst 1
}
proc setcanvscroll {} {
global canv canv2 canv3 numcommits linespc canvxmax canvy0
set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
$canv conf -scrollregion [list 0 0 $canvxmax $ymax]
$canv2 conf -scrollregion [list 0 0 0 $ymax]
$canv3 conf -scrollregion [list 0 0 0 $ymax]
}
proc visiblerows {} {
global canv numcommits linespc
set ymax [lindex [$canv cget -scrollregion] 3]
if {$ymax eq {} || $ymax == 0} return
set f [$canv yview]
set y0 [expr {int([lindex $f 0] * $ymax)}]
set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
if {$r0 < 0} {
set r0 0
}
set y1 [expr {int([lindex $f 1] * $ymax)}]
set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
if {$r1 >= $numcommits} {
set r1 [expr {$numcommits - 1}]
}
return [list $r0 $r1]
}
proc layoutmore {} {
global commitidx viewcomplete numcommits
global uparrowlen downarrowlen mingaplen curview
set show $commitidx($curview)
if {$show > $numcommits || $viewcomplete($curview)} {
showstuff $show $viewcomplete($curview)
}
}
proc showstuff {canshow last} {
global numcommits commitrow pending_select selectedline curview
global mainheadid displayorder selectfirst
global lastscrollset commitinterest
if {$numcommits == 0} {
global phase
set phase "incrdraw"
allcanvs delete all
}
set r0 $numcommits
set prev $numcommits
set numcommits $canshow
set t [clock clicks -milliseconds]
if {$prev < 100 || $last || $t - $lastscrollset > 500} {
set lastscrollset $t
setcanvscroll
}
set rows [visiblerows]
set r1 [lindex $rows 1]
if {$r1 >= $canshow} {
set r1 [expr {$canshow - 1}]
}
if {$r0 <= $r1} {
drawcommits $r0 $r1
}
if {[info exists pending_select] &&
[info exists commitrow($curview,$pending_select)] &&
$commitrow($curview,$pending_select) < $numcommits} {
selectline $commitrow($curview,$pending_select) 1
}
if {$selectfirst} {
if {[info exists selectedline] || [info exists pending_select]} {
set selectfirst 0
} else {
set l [first_real_row]
selectline $l 1
set selectfirst 0
}
}
}
proc doshowlocalchanges {} {
global curview mainheadid phase commitrow
if {[info exists commitrow($curview,$mainheadid)] &&
($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
dodiffindex
} elseif {$phase ne {}} {
lappend commitinterest($mainheadid) {}
}
}
proc dohidelocalchanges {} {
global localfrow localirow lserial
if {$localfrow >= 0} {
removerow $localfrow
set localfrow -1
if {$localirow > 0} {
incr localirow -1
}
}
if {$localirow >= 0} {
removerow $localirow
set localirow -1
}
incr lserial
}
# spawn off a process to do git diff-index --cached HEAD
proc dodiffindex {} {
global localirow localfrow lserial showlocalchanges
if {!$showlocalchanges} return
incr lserial
set localfrow -1
set localirow -1
set fd [open "|git diff-index --cached HEAD" r]
fconfigure $fd -blocking 0
filerun $fd [list readdiffindex $fd $lserial]
}
proc readdiffindex {fd serial} {
global localirow commitrow mainheadid nullid2 curview
global commitinfo commitdata lserial
set isdiff 1
if {[gets $fd line] < 0} {
if {![eof $fd]} {
return 1
}
set isdiff 0
}
# we only need to see one line and we don't really care what it says...
close $fd
# now see if there are any local changes not checked in to the index
if {$serial == $lserial} {
set fd [open "|git diff-files" r]
fconfigure $fd -blocking 0
filerun $fd [list readdifffiles $fd $serial]
}
if {$isdiff && $serial == $lserial && $localirow == -1} {
# add the line for the changes in the index to the graph
set localirow $commitrow($curview,$mainheadid)
set hl [mc "Local changes checked in to index but not committed"]
set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
set commitdata($nullid2) "\n $hl\n"
insertrow $localirow $nullid2
}
return 0
}
proc readdifffiles {fd serial} {
global localirow localfrow commitrow mainheadid nullid curview
global commitinfo commitdata lserial
set isdiff 1
if {[gets $fd line] < 0} {
if {![eof $fd]} {
return 1
}
set isdiff 0
}
# we only need to see one line and we don't really care what it says...
close $fd
if {$isdiff && $serial == $lserial && $localfrow == -1} {
# add the line for the local diff to the graph
if {$localirow >= 0} {
set localfrow $localirow
incr localirow
} else {
set localfrow $commitrow($curview,$mainheadid)
}
set hl [mc "Local uncommitted changes, not checked in to index"]
set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
set commitdata($nullid) "\n $hl\n"
insertrow $localfrow $nullid
}
return 0
}
proc nextuse {id row} {
global commitrow curview children
if {[info exists children($curview,$id)]} {
foreach kid $children($curview,$id) {
if {![info exists commitrow($curview,$kid)]} {
return -1
}
if {$commitrow($curview,$kid) > $row} {
return $commitrow($curview,$kid)
}
}
}
if {[info exists commitrow($curview,$id)]} {
return $commitrow($curview,$id)
}
return -1
}
proc prevuse {id row} {
global commitrow curview children
set ret -1
if {[info exists children($curview,$id)]} {
foreach kid $children($curview,$id) {
if {![info exists commitrow($curview,$kid)]} break
if {$commitrow($curview,$kid) < $row} {
set ret $commitrow($curview,$kid)
}
}
}
return $ret
}
proc make_idlist {row} {
global displayorder parentlist uparrowlen downarrowlen mingaplen
global commitidx curview ordertok children commitrow
set r [expr {$row - $mingaplen - $downarrowlen - 1}]
if {$r < 0} {
set r 0
}
set ra [expr {$row - $downarrowlen}]
if {$ra < 0} {
set ra 0
}
set rb [expr {$row + $uparrowlen}]
if {$rb > $commitidx($curview)} {
set rb $commitidx($curview)
}
set ids {}
for {} {$r < $ra} {incr r} {
set nextid [lindex $displayorder [expr {$r + 1}]]
foreach p [lindex $parentlist $r] {
if {$p eq $nextid} continue
set rn [nextuse $p $r]
if {$rn >= $row &&
$rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
lappend ids [list $ordertok($curview,$p) $p]
}
}
}
for {} {$r < $row} {incr r} {
set nextid [lindex $displayorder [expr {$r + 1}]]
foreach p [lindex $parentlist $r] {
if {$p eq $nextid} continue
set rn [nextuse $p $r]
if {$rn < 0 || $rn >= $row} {
lappend ids [list $ordertok($curview,$p) $p]
}
}
}
set id [lindex $displayorder $row]
lappend ids [list $ordertok($curview,$id) $id]
while {$r < $rb} {
foreach p [lindex $parentlist $r] {
set firstkid [lindex $children($curview,$p) 0]
if {$commitrow($curview,$firstkid) < $row} {
lappend ids [list $ordertok($curview,$p) $p]
}
}
incr r
set id [lindex $displayorder $r]
if {$id ne {}} {
set firstkid [lindex $children($curview,$id) 0]
if {$firstkid ne {} && $commitrow($curview,$firstkid) < $row} {
lappend ids [list $ordertok($curview,$id) $id]
}
}
}
set idlist {}
foreach idx [lsort -unique $ids] {
lappend idlist [lindex $idx 1]
}
return $idlist
}
proc rowsequal {a b} {
while {[set i [lsearch -exact $a {}]] >= 0} {
set a [lreplace $a $i $i]
}
while {[set i [lsearch -exact $b {}]] >= 0} {
set b [lreplace $b $i $i]
}
return [expr {$a eq $b}]
}
proc makeupline {id row rend col} {
global rowidlist uparrowlen downarrowlen mingaplen
for {set r $rend} {1} {set r $rstart} {
set rstart [prevuse $id $r]
if {$rstart < 0} return
if {$rstart < $row} break
}
if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
set rstart [expr {$rend - $uparrowlen - 1}]
}
for {set r $rstart} {[incr r] <= $row} {} {
set idlist [lindex $rowidlist $r]
if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
set col [idcol $idlist $id $col]
lset rowidlist $r [linsert $idlist $col $id]
changedrow $r
}
}
}
proc layoutrows {row endrow} {
global rowidlist rowisopt rowfinal displayorder
global uparrowlen downarrowlen maxwidth mingaplen
global children parentlist
global commitidx viewcomplete curview commitrow
set idlist {}
if {$row > 0} {
set rm1 [expr {$row - 1}]
foreach id [lindex $rowidlist $rm1] {
if {$id ne {}} {
lappend idlist $id
}
}
set final [lindex $rowfinal $rm1]
}
for {} {$row < $endrow} {incr row} {
set rm1 [expr {$row - 1}]
if {$rm1 < 0 || $idlist eq {}} {
set idlist [make_idlist $row]
set final 1
} else {
set id [lindex $displayorder $rm1]
set col [lsearch -exact $idlist $id]
set idlist [lreplace $idlist $col $col]
foreach p [lindex $parentlist $rm1] {
if {[lsearch -exact $idlist $p] < 0} {
set col [idcol $idlist $p $col]
set idlist [linsert $idlist $col $p]
# if not the first child, we have to insert a line going up
if {$id ne [lindex $children($curview,$p) 0]} {
makeupline $p $rm1 $row $col
}
}
}
set id [lindex $displayorder $row]
if {$row > $downarrowlen} {
set termrow [expr {$row - $downarrowlen - 1}]
foreach p [lindex $parentlist $termrow] {
set i [lsearch -exact $idlist $p]
if {$i < 0} continue
set nr [nextuse $p $termrow]
if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
set idlist [lreplace $idlist $i $i]
}
}
}
set col [lsearch -exact $idlist $id]
if {$col < 0} {
set col [idcol $idlist $id]
set idlist [linsert $idlist $col $id]
if {$children($curview,$id) ne {}} {
makeupline $id $rm1 $row $col
}
}
set r [expr {$row + $uparrowlen - 1}]
if {$r < $commitidx($curview)} {
set x $col
foreach p [lindex $parentlist $r] {
if {[lsearch -exact $idlist $p] >= 0} continue
set fk [lindex $children($curview,$p) 0]
if {$commitrow($curview,$fk) < $row} {
set x [idcol $idlist $p $x]
set idlist [linsert $idlist $x $p]
}
}
if {[incr r] < $commitidx($curview)} {
set p [lindex $displayorder $r]
if {[lsearch -exact $idlist $p] < 0} {
set fk [lindex $children($curview,$p) 0]
if {$fk ne {} && $commitrow($curview,$fk) < $row} {
set x [idcol $idlist $p $x]
set idlist [linsert $idlist $x $p]
}
}
}
}
}
if {$final && !$viewcomplete($curview) &&
$row + $uparrowlen + $mingaplen + $downarrowlen
>= $commitidx($curview)} {
set final 0
}
set l [llength $rowidlist]
if {$row == $l} {
lappend rowidlist $idlist
lappend rowisopt 0
lappend rowfinal $final
} elseif {$row < $l} {
if {![rowsequal $idlist [lindex $rowidlist $row]]} {
lset rowidlist $row $idlist
changedrow $row
}
lset rowfinal $row $final
} else {
set pad [ntimes [expr {$row - $l}] {}]
set rowidlist [concat $rowidlist $pad]
lappend rowidlist $idlist
set rowfinal [concat $rowfinal $pad]
lappend rowfinal $final
set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
}
}
return $row
}
proc changedrow {row} {
global displayorder iddrawn rowisopt need_redisplay
set l [llength $rowisopt]
if {$row < $l} {
lset rowisopt $row 0
if {$row + 1 < $l} {
lset rowisopt [expr {$row + 1}] 0
if {$row + 2 < $l} {
lset rowisopt [expr {$row + 2}] 0
}
}
}
set id [lindex $displayorder $row]
if {[info exists iddrawn($id)]} {
set need_redisplay 1
}
}
proc insert_pad {row col npad} {
global rowidlist
set pad [ntimes $npad {}]
set idlist [lindex $rowidlist $row]
set bef [lrange $idlist 0 [expr {$col - 1}]]
set aft [lrange $idlist $col end]
set i [lsearch -exact $aft {}]
if {$i > 0} {
set aft [lreplace $aft $i $i]
}
lset rowidlist $row [concat $bef $pad $aft]
changedrow $row
}
proc optimize_rows {row col endrow} {
global rowidlist rowisopt displayorder curview children
if {$row < 1} {
set row 1
}
for {} {$row < $endrow} {incr row; set col 0} {
if {[lindex $rowisopt $row]} continue
set haspad 0
set y0 [expr {$row - 1}]
set ym [expr {$row - 2}]
set idlist [lindex $rowidlist $row]
set previdlist [lindex $rowidlist $y0]
if {$idlist eq {} || $previdlist eq {}} continue
if {$ym >= 0} {
set pprevidlist [lindex $rowidlist $ym]
if {$pprevidlist eq {}} continue
} else {
set pprevidlist {}
}
set x0 -1
set xm -1
for {} {$col < [llength $idlist]} {incr col} {
set id [lindex $idlist $col]
if {[lindex $previdlist $col] eq $id} continue
if {$id eq {}} {
set haspad 1
continue
}
set x0 [lsearch -exact $previdlist $id]
if {$x0 < 0} continue
set z [expr {$x0 - $col}]
set isarrow 0
set z0 {}
if {$ym >= 0} {
set xm [lsearch -exact $pprevidlist $id]
if {$xm >= 0} {
set z0 [expr {$xm - $x0}]
}
}
if {$z0 eq {}} {
# if row y0 is the first child of $id then it's not an arrow
if {[lindex $children($curview,$id) 0] ne
[lindex $displayorder $y0]} {
set isarrow 1
}
}
if {!$isarrow && $id ne [lindex $displayorder $row] &&
[lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
set isarrow 1
}
# Looking at lines from this row to the previous row,
# make them go straight up if they end in an arrow on
# the previous row; otherwise make them go straight up
# or at 45 degrees.
if {$z < -1 || ($z < 0 && $isarrow)} {
# Line currently goes left too much;
# insert pads in the previous row, then optimize it
set npad [expr {-1 - $z + $isarrow}]
insert_pad $y0 $x0 $npad
if {$y0 > 0} {
optimize_rows $y0 $x0 $row
}
set previdlist [lindex $rowidlist $y0]
set x0 [lsearch -exact $previdlist $id]
set z [expr {$x0 - $col}]
if {$z0 ne {}} {
set pprevidlist [lindex $rowidlist $ym]
set xm [lsearch -exact $pprevidlist $id]
set z0 [expr {$xm - $x0}]
}
} elseif {$z > 1 || ($z > 0 && $isarrow)} {
# Line currently goes right too much;
# insert pads in this line
set npad [expr {$z - 1 + $isarrow}]
insert_pad $row $col $npad
set idlist [lindex $rowidlist $row]
incr col $npad
set z [expr {$x0 - $col}]
set haspad 1
}
if {$z0 eq {} && !$isarrow && $ym >= 0} {
# this line links to its first child on row $row-2
set id [lindex $displayorder $ym]
set xc [lsearch -exact $pprevidlist $id]
if {$xc >= 0} {
set z0 [expr {$xc - $x0}]
}
}
# avoid lines jigging left then immediately right
if {$z0 ne {} && $z < 0 && $z0 > 0} {
insert_pad $y0 $x0 1
incr x0
optimize_rows $y0 $x0 $row
set previdlist [lindex $rowidlist $y0]
}
}
if {!$haspad} {
# Find the first column that doesn't have a line going right
for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
set id [lindex $idlist $col]
if {$id eq {}} break
set x0 [lsearch -exact $previdlist $id]
if {$x0 < 0} {
# check if this is the link to the first child
set kid [lindex $displayorder $y0]
if {[lindex $children($curview,$id) 0] eq $kid} {
# it is, work out offset to child
set x0 [lsearch -exact $previdlist $kid]
}
}
if {$x0 <= $col} break
}
# Insert a pad at that column as long as it has a line and
# isn't the last column
if {$x0 >= 0 && [incr col] < [llength $idlist]} {
set idlist [linsert $idlist $col {}]
lset rowidlist $row $idlist
changedrow $row
}
}
}
}
proc xc {row col} {
global canvx0 linespc
return [expr {$canvx0 + $col * $linespc}]
}
proc yc {row} {
global canvy0 linespc
return [expr {$canvy0 + $row * $linespc}]
}
proc linewidth {id} {
global thickerline lthickness
set wid $lthickness
if {[info exists thickerline] && $id eq $thickerline} {
set wid [expr {2 * $lthickness}]
}
return $wid
}
proc rowranges {id} {
global commitrow curview children uparrowlen downarrowlen
global rowidlist
set kids $children($curview,$id)
if {$kids eq {}} {
return {}
}
set ret {}
lappend kids $id
foreach child $kids {
if {![info exists commitrow($curview,$child)]} break
set row $commitrow($curview,$child)
if {![info exists prev]} {
lappend ret [expr {$row + 1}]
} else {
if {$row <= $prevrow} {
puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
}
# see if the line extends the whole way from prevrow to row
if {$row > $prevrow + $uparrowlen + $downarrowlen &&
[lsearch -exact [lindex $rowidlist \
[expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
# it doesn't, see where it ends
set r [expr {$prevrow + $downarrowlen}]
if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
while {[incr r -1] > $prevrow &&
[lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
} else {
while {[incr r] <= $row &&
[lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
incr r -1
}
lappend ret $r
# see where it starts up again
set r [expr {$row - $uparrowlen}]
if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
while {[incr r] < $row &&
[lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
} else {
while {[incr r -1] >= $prevrow &&
[lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
incr r
}
lappend ret $r
}
}
if {$child eq $id} {
lappend ret $row
}
set prev $id
set prevrow $row
}
return $ret
}
proc drawlineseg {id row endrow arrowlow} {
global rowidlist displayorder iddrawn linesegs
global canv colormap linespc curview maxlinelen parentlist
set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
set le [expr {$row + 1}]
set arrowhigh 1
while {1} {
set c [lsearch -exact [lindex $rowidlist $le] $id]
if {$c < 0} {
incr le -1
break
}
lappend cols $c
set x [lindex $displayorder $le]
if {$x eq $id} {
set arrowhigh 0
break
}
if {[info exists iddrawn($x)] || $le == $endrow} {
set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
if {$c >= 0} {
lappend cols $c
set arrowhigh 0
}
break
}
incr le
}
if {$le <= $row} {
return $row
}
set lines {}
set i 0
set joinhigh 0
if {[info exists linesegs($id)]} {
set lines $linesegs($id)
foreach li $lines {
set r0 [lindex $li 0]
if {$r0 > $row} {
if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
set joinhigh 1
}
break
}
incr i
}
}
set joinlow 0
if {$i > 0} {
set li [lindex $lines [expr {$i-1}]]
set r1 [lindex $li 1]
if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
set joinlow 1
}
}
set x [lindex $cols [expr {$le - $row}]]
set xp [lindex $cols [expr {$le - 1 - $row}]]
set dir [expr {$xp - $x}]
if {$joinhigh} {
set ith [lindex $lines $i 2]
set coords [$canv coords $ith]
set ah [$canv itemcget $ith -arrow]
set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
set x2 [lindex $cols [expr {$le + 1 - $row}]]
if {$x2 ne {} && $x - $x2 == $dir} {
set coords [lrange $coords 0 end-2]
}
} else {
set coords [list [xc $le $x] [yc $le]]
}
if {$joinlow} {
set itl [lindex $lines [expr {$i-1}] 2]
set al [$canv itemcget $itl -arrow]
set arrowlow [expr {$al eq "last" || $al eq "both"}]
} elseif {$arrowlow} {
if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
[lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
set arrowlow 0
}
}
set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
for {set y $le} {[incr y -1] > $row} {} {
set x $xp
set xp [lindex $cols [expr {$y - 1 - $row}]]
set ndir [expr {$xp - $x}]
if {$dir != $ndir || $xp < 0} {
lappend coords [xc $y $x] [yc $y]
}
set dir $ndir
}
if {!$joinlow} {
if {$xp < 0} {
# join parent line to first child
set ch [lindex $displayorder $row]
set xc [lsearch -exact [lindex $rowidlist $row] $ch]
if {$xc < 0} {
puts "oops: drawlineseg: child $ch not on row $row"
} elseif {$xc != $x} {
if {($arrowhigh && $le == $row + 1) || $dir == 0} {
set d [expr {int(0.5 * $linespc)}]
set x1 [xc $row $x]
if {$xc < $x} {
set x2 [expr {$x1 - $d}]
} else {
set x2 [expr {$x1 + $d}]
}
set y2 [yc $row]
set y1 [expr {$y2 + $d}]
lappend coords $x1 $y1 $x2 $y2
} elseif {$xc < $x - 1} {
lappend coords [xc $row [expr {$x-1}]] [yc $row]
} elseif {$xc > $x + 1} {
lappend coords [xc $row [expr {$x+1}]] [yc $row]
}
set x $xc
}
lappend coords [xc $row $x] [yc $row]
} else {
set xn [xc $row $xp]
set yn [yc $row]
lappend coords $xn $yn
}
if {!$joinhigh} {
assigncolor $id
set t [$canv create line $coords -width [linewidth $id] \
-fill $colormap($id) -tags lines.$id -arrow $arrow]
$canv lower $t
bindline $t $id
set lines [linsert $lines $i [list $row $le $t]]
} else {
$canv coords $ith $coords
if {$arrow ne $ah} {
$canv itemconf $ith -arrow $arrow
}
lset lines $i 0 $row
}
} else {
set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
set ndir [expr {$xo - $xp}]
set clow [$canv coords $itl]
if {$dir == $ndir} {
set clow [lrange $clow 2 end]
}
set coords [concat $coords $clow]
if {!$joinhigh} {
lset lines [expr {$i-1}] 1 $le
} else {
# coalesce two pieces
$canv delete $ith
set b [lindex $lines [expr {$i-1}] 0]
set e [lindex $lines $i 1]
set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
}
$canv coords $itl $coords
if {$arrow ne $al} {
$canv itemconf $itl -arrow $arrow
}
}
set linesegs($id) $lines
return $le
}
proc drawparentlinks {id row} {
global rowidlist canv colormap curview parentlist
global idpos linespc
set rowids [lindex $rowidlist $row]
set col [lsearch -exact $rowids $id]
if {$col < 0} return
set olds [lindex $parentlist $row]
set row2 [expr {$row + 1}]
set x [xc $row $col]
set y [yc $row]
set y2 [yc $row2]
set d [expr {int(0.5 * $linespc)}]
set ymid [expr {$y + $d}]
set ids [lindex $rowidlist $row2]
# rmx = right-most X coord used
set rmx 0
foreach p $olds {
set i [lsearch -exact $ids $p]
if {$i < 0} {
puts "oops, parent $p of $id not in list"
continue
}
set x2 [xc $row2 $i]
if {$x2 > $rmx} {
set rmx $x2
}
set j [lsearch -exact $rowids $p]
if {$j < 0} {
# drawlineseg will do this one for us
continue
}
assigncolor $p
# should handle duplicated parents here...
set coords [list $x $y]
if {$i != $col} {
# if attaching to a vertical segment, draw a smaller
# slant for visual distinctness
if {$i == $j} {
if {$i < $col} {
lappend coords [expr {$x2 + $d}] $y $x2 $ymid
} else {
lappend coords [expr {$x2 - $d}] $y $x2 $ymid
}
} elseif {$i < $col && $i < $j} {
# segment slants towards us already
lappend coords [xc $row $j] $y
} else {
if {$i < $col - 1} {
lappend coords [expr {$x2 + $linespc}] $y
} elseif {$i > $col + 1} {
lappend coords [expr {$x2 - $linespc}] $y
}
lappend coords $x2 $y2
}
} else {
lappend coords $x2 $y2
}
set t [$canv create line $coords -width [linewidth $p] \
-fill $colormap($p) -tags lines.$p]
$canv lower $t
bindline $t $p
}
if {$rmx > [lindex $idpos($id) 1]} {
lset idpos($id) 1 $rmx
redrawtags $id
}
}
proc drawlines {id} {
global canv
$canv itemconf lines.$id -width [linewidth $id]
}
proc drawcmittext {id row col} {
global linespc canv canv2 canv3 canvy0 fgcolor curview
global commitlisted commitinfo rowidlist parentlist
global rowtextx idpos idtags idheads idotherrefs
global linehtag linentag linedtag selectedline
global canvxmax boldrows boldnamerows fgcolor nullid nullid2
# listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
set listed [lindex $commitlisted $row]
if {$id eq $nullid} {
set ofill red
} elseif {$id eq $nullid2} {
set ofill green
} else {
set ofill [expr {$listed != 0? "blue": "white"}]
}
set x [xc $row $col]
set y [yc $row]
set orad [expr {$linespc / 3}]
if {$listed <= 1} {
set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
[expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
-fill $ofill -outline $fgcolor -width 1 -tags circle]
} elseif {$listed == 2} {
# triangle pointing left for left-side commits
set t [$canv create polygon \
[expr {$x - $orad}] $y \
[expr {$x + $orad - 1}] [expr {$y - $orad}] \
[expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
-fill $ofill -outline $fgcolor -width 1 -tags circle]
} else {
# triangle pointing right for right-side commits
set t [$canv create polygon \
[expr {$x + $orad - 1}] $y \
[expr {$x - $orad}] [expr {$y - $orad}] \
[expr {$x - $orad}] [expr {$y + $orad - 1}] \
-fill $ofill -outline $fgcolor -width 1 -tags circle]
}
$canv raise $t
$canv bind $t <1> {selcanvline {} %x %y}
set rmx [llength [lindex $rowidlist $row]]
set olds [lindex $parentlist $row]
if {$olds ne {}} {
set nextids [lindex $rowidlist [expr {$row + 1}]]
foreach p $olds {
set i [lsearch -exact $nextids $p]
if {$i > $rmx} {
set rmx $i
}
}
}
set xt [xc $row $rmx]
set rowtextx($row) $xt
set idpos($id) [list $x $xt $y]
if {[info exists idtags($id)] || [info exists idheads($id)]
|| [info exists idotherrefs($id)]} {
set xt [drawtags $id $x $xt $y]
}
set headline [lindex $commitinfo($id) 0]
set name [lindex $commitinfo($id) 1]
set date [lindex $commitinfo($id) 2]
set date [formatdate $date]
set font mainfont
set nfont mainfont
set isbold [ishighlighted $row]
if {$isbold > 0} {
lappend boldrows $row
set font mainfontbold
if {$isbold > 1} {
lappend boldnamerows $row
set nfont mainfontbold
}
}
set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
-text $headline -font $font -tags text]
$canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
-text $name -font $nfont -tags text]
set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
-text $date -font mainfont -tags text]
if {[info exists selectedline] && $selectedline == $row} {
make_secsel $row
}
set xr [expr {$xt + [font measure $font $headline]}]
if {$xr > $canvxmax} {
set canvxmax $xr
setcanvscroll
}
}
proc drawcmitrow {row} {
global displayorder rowidlist nrows_drawn
global iddrawn markingmatches
global commitinfo parentlist numcommits
global filehighlight fhighlights findpattern nhighlights
global hlview vhighlights
global highlight_related rhighlights
if {$row >= $numcommits} return
set id [lindex $displayorder $row]
if {[info exists hlview] && ![info exists vhighlights($row)]} {
askvhighlight $row $id
}
if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
askfilehighlight $row $id
}
if {$findpattern ne {} && ![info exists nhighlights($row)]} {
askfindhighlight $row $id
}
if {$highlight_related ne [mc "None"] && ![info exists rhighlights($row)]} {
askrelhighlight $row $id
}
if {![info exists iddrawn($id)]} {
set col [lsearch -exact [lindex $rowidlist $row] $id]
if {$col < 0} {
puts "oops, row $row id $id not in list"
return
}
if {![info exists commitinfo($id)]} {
getcommit $id
}
assigncolor $id
drawcmittext $id $row $col
set iddrawn($id) 1
incr nrows_drawn
}
if {$markingmatches} {
markrowmatches $row $id
}
}
proc drawcommits {row {endrow {}}} {