| #!/bin/sh |
| # Tcl ignores the next line -*- tcl -*- \ |
| exec wish "$0" -- "$@" |
| |
| # Copyright (C) 2005 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 ".git" |
| } |
| } |
| |
| proc parse_args {rargs} { |
| global parsed_args |
| |
| if [catch { |
| set parse_args [concat --default HEAD $rargs] |
| set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"] |
| }] { |
| # if git-rev-parse failed for some reason... |
| if {$rargs == {}} { |
| set rargs HEAD |
| } |
| set parsed_args $rargs |
| } |
| return $parsed_args |
| } |
| |
| proc start_rev_list {rlargs} { |
| global startmsecs nextupdate ncmupdate |
| global commfd leftover tclencoding |
| |
| set startmsecs [clock clicks -milliseconds] |
| set nextupdate [expr {$startmsecs + 100}] |
| set ncmupdate 1 |
| if [catch { |
| set commfd [open [concat | git-rev-list --header --topo-order \ |
| --parents $rlargs] r] |
| } err] { |
| puts stderr "Error executing git-rev-list: $err" |
| exit 1 |
| } |
| set leftover {} |
| fconfigure $commfd -blocking 0 -translation lf |
| if {$tclencoding != {}} { |
| fconfigure $commfd -encoding $tclencoding |
| } |
| fileevent $commfd readable [list getcommitlines $commfd] |
| . config -cursor watch |
| settextcursor watch |
| } |
| |
| proc getcommits {rargs} { |
| global oldcommits commits phase canv mainfont env |
| |
| # check that we can find a .git directory somewhere... |
| set gitdir [gitdir] |
| if {![file isdirectory $gitdir]} { |
| error_popup "Cannot find the git directory \"$gitdir\"." |
| exit 1 |
| } |
| set oldcommits {} |
| set commits {} |
| set phase getcommits |
| start_rev_list [parse_args $rargs] |
| $canv delete all |
| $canv create text 3 3 -anchor nw -text "Reading commits..." \ |
| -font $mainfont -tags textitems |
| } |
| |
| proc getcommitlines {commfd} { |
| global oldcommits commits parents cdate children nchildren |
| global commitlisted phase nextupdate |
| global stopped redisplaying leftover |
| global canv |
| |
| set stuff [read $commfd] |
| if {$stuff == {}} { |
| if {![eof $commfd]} return |
| # set it blocking so we wait for the process to terminate |
| fconfigure $commfd -blocking 1 |
| if {![catch {close $commfd} err]} { |
| after idle finishcommits |
| return |
| } |
| if {[string range $err 0 4] == "usage"} { |
| set err \ |
| "Gitk: error reading commits: bad arguments to git-rev-list.\ |
| (Note: arguments to gitk are passed to git-rev-list\ |
| to allow selection of commits to be displayed.)" |
| } else { |
| set err "Error reading commits: $err" |
| } |
| error_popup $err |
| exit 1 |
| } |
| set start 0 |
| while 1 { |
| set i [string first "\0" $stuff $start] |
| if {$i < 0} { |
| append leftover [string range $stuff $start end] |
| return |
| } |
| set cmit [string range $stuff $start [expr {$i - 1}]] |
| if {$start == 0} { |
| set cmit "$leftover$cmit" |
| set leftover {} |
| } |
| set start [expr {$i + 1}] |
| set j [string first "\n" $cmit] |
| set ok 0 |
| if {$j >= 0} { |
| set ids [string range $cmit 0 [expr {$j - 1}]] |
| set ok 1 |
| foreach id $ids { |
| if {![regexp {^[0-9a-f]{40}$} $id]} { |
| set ok 0 |
| break |
| } |
| } |
| } |
| if {!$ok} { |
| set shortcmit $cmit |
| if {[string length $shortcmit] > 80} { |
| set shortcmit "[string range $shortcmit 0 80]..." |
| } |
| error_popup "Can't parse git-rev-list output: {$shortcmit}" |
| exit 1 |
| } |
| set id [lindex $ids 0] |
| set olds [lrange $ids 1 end] |
| set cmit [string range $cmit [expr {$j + 1}] end] |
| lappend commits $id |
| set commitlisted($id) 1 |
| parsecommit $id $cmit 1 [lrange $ids 1 end] |
| drawcommit $id 1 |
| if {[clock clicks -milliseconds] >= $nextupdate} { |
| doupdate 1 |
| } |
| while {$redisplaying} { |
| set redisplaying 0 |
| if {$stopped == 1} { |
| set stopped 0 |
| set phase "getcommits" |
| foreach id $commits { |
| drawcommit $id 1 |
| if {$stopped} break |
| if {[clock clicks -milliseconds] >= $nextupdate} { |
| doupdate 1 |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| proc doupdate {reading} { |
| global commfd nextupdate numcommits ncmupdate |
| |
| if {$reading} { |
| fileevent $commfd readable {} |
| } |
| update |
| set nextupdate [expr {[clock clicks -milliseconds] + 100}] |
| if {$numcommits < 100} { |
| set ncmupdate [expr {$numcommits + 1}] |
| } elseif {$numcommits < 10000} { |
| set ncmupdate [expr {$numcommits + 10}] |
| } else { |
| set ncmupdate [expr {$numcommits + 100}] |
| } |
| if {$reading} { |
| fileevent $commfd readable [list getcommitlines $commfd] |
| } |
| } |
| |
| proc readcommit {id} { |
| if [catch {set contents [exec git-cat-file commit $id]}] return |
| parsecommit $id $contents 0 {} |
| } |
| |
| proc updatecommits {rargs} { |
| global commitlisted commfd phase |
| global startmsecs nextupdate ncmupdate |
| global idtags idheads idotherrefs |
| global leftover |
| global parsed_args |
| global canv mainfont |
| global oldcommits commits |
| global parents nchildren children ncleft |
| |
| set old_args $parsed_args |
| parse_args $rargs |
| |
| if {$phase == "getcommits" || $phase == "incrdraw"} { |
| # havent read all the old commits, just start again from scratch |
| stopfindproc |
| set oldcommits {} |
| set commits {} |
| foreach v {children nchildren parents commitlisted commitinfo |
| selectedline matchinglines treediffs |
| mergefilelist currentid rowtextx} { |
| global $v |
| catch {unset $v} |
| } |
| readrefs |
| if {$phase == "incrdraw"} { |
| allcanvs delete all |
| $canv create text 3 3 -anchor nw -text "Reading commits..." \ |
| -font $mainfont -tags textitems |
| set phase getcommits |
| } |
| start_rev_list $parsed_args |
| return |
| } |
| |
| foreach id $old_args { |
| if {![regexp {^[0-9a-f]{40}$} $id]} continue |
| if {[info exists oldref($id)]} continue |
| set oldref($id) $id |
| lappend ignoreold "^$id" |
| } |
| foreach id $parsed_args { |
| if {![regexp {^[0-9a-f]{40}$} $id]} continue |
| if {[info exists ref($id)]} continue |
| set ref($id) $id |
| lappend ignorenew "^$id" |
| } |
| |
| foreach a $old_args { |
| if {![info exists ref($a)]} { |
| lappend ignorenew $a |
| } |
| } |
| |
| set phase updatecommits |
| set oldcommits $commits |
| set commits {} |
| set removed_commits [split [eval exec git-rev-list $ignorenew] "\n" ] |
| if {[llength $removed_commits] > 0} { |
| allcanvs delete all |
| foreach c $removed_commits { |
| set i [lsearch -exact $oldcommits $c] |
| if {$i >= 0} { |
| set oldcommits [lreplace $oldcommits $i $i] |
| unset commitlisted($c) |
| foreach p $parents($c) { |
| if {[info exists nchildren($p)]} { |
| set j [lsearch -exact $children($p) $c] |
| if {$j >= 0} { |
| set children($p) [lreplace $children($p) $j $j] |
| incr nchildren($p) -1 |
| } |
| } |
| } |
| } |
| } |
| set phase removecommits |
| } |
| |
| set args {} |
| foreach a $parsed_args { |
| if {![info exists oldref($a)]} { |
| lappend args $a |
| } |
| } |
| |
| readrefs |
| start_rev_list [concat $ignoreold $args] |
| } |
| |
| proc updatechildren {id olds} { |
| global children nchildren parents nparents ncleft |
| |
| if {![info exists nchildren($id)]} { |
| set children($id) {} |
| set nchildren($id) 0 |
| set ncleft($id) 0 |
| } |
| set parents($id) $olds |
| set nparents($id) [llength $olds] |
| foreach p $olds { |
| if {![info exists nchildren($p)]} { |
| set children($p) [list $id] |
| set nchildren($p) 1 |
| set ncleft($p) 1 |
| } elseif {[lsearch -exact $children($p) $id] < 0} { |
| lappend children($p) $id |
| incr nchildren($p) |
| incr ncleft($p) |
| } |
| } |
| } |
| |
| proc parsecommit {id contents listed olds} { |
| global commitinfo cdate |
| |
| set inhdr 1 |
| set comment {} |
| set headline {} |
| set auname {} |
| set audate {} |
| set comname {} |
| set comdate {} |
| updatechildren $id $olds |
| 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 line of the comment as the headline |
| set i [string first "\n" $comment] |
| if {$i >= 0} { |
| set headline [string trim [string range $comment 0 $i]] |
| } else { |
| set headline $comment |
| } |
| 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 readrefs {} { |
| global tagids idtags headids idheads tagcontents |
| global otherrefids idotherrefs |
| |
| foreach v {tagids idtags headids idheads otherrefids idotherrefs} { |
| catch {unset $v} |
| } |
| set refd [open [list | git-ls-remote [gitdir]] r] |
| while {0 <= [set n [gets $refd line]]} { |
| if {![regexp {^([0-9a-f]{40}) refs/([^^]*)$} $line \ |
| match id path]} { |
| continue |
| } |
| if {![regexp {^(tags|heads)/(.*)$} $path match type name]} { |
| set type others |
| set name $path |
| } |
| if {$type == "tags"} { |
| set tagids($name) $id |
| lappend idtags($id) $name |
| set obj {} |
| set type {} |
| set tag {} |
| catch { |
| set commit [exec git-rev-parse "$id^0"] |
| if {"$commit" != "$id"} { |
| set tagids($name) $commit |
| lappend idtags($commit) $name |
| } |
| } |
| catch { |
| set tagcontents($name) [exec git-cat-file tag "$id"] |
| } |
| } elseif { $type == "heads" } { |
| set headids($name) $id |
| lappend idheads($id) $name |
| } else { |
| set otherrefids($name) $id |
| lappend idotherrefs($id) $name |
| } |
| } |
| close $refd |
| } |
| |
| proc error_popup msg { |
| set w .error |
| 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 OK -command "destroy $w" |
| pack $w.ok -side bottom -fill x |
| bind $w <Visibility> "grab $w; focus $w" |
| tkwait window $w |
| } |
| |
| proc makewindow {rargs} { |
| global canv canv2 canv3 linespc charspc ctext cflist textfont |
| global findtype findtypemenu findloc findstring fstring geometry |
| global entries sha1entry sha1string sha1but |
| global maincursor textcursor curtextcursor |
| global rowctxmenu mergemax |
| |
| menu .bar |
| .bar add cascade -label "File" -menu .bar.file |
| menu .bar.file |
| .bar.file add command -label "Update" -command [list updatecommits $rargs] |
| .bar.file add command -label "Reread references" -command rereadrefs |
| .bar.file add command -label "Quit" -command doquit |
| menu .bar.edit |
| .bar add cascade -label "Edit" -menu .bar.edit |
| .bar.edit add command -label "Preferences" -command doprefs |
| menu .bar.help |
| .bar add cascade -label "Help" -menu .bar.help |
| .bar.help add command -label "About gitk" -command about |
| . configure -menu .bar |
| |
| if {![info exists geometry(canv1)]} { |
| set geometry(canv1) [expr {45 * $charspc}] |
| set geometry(canv2) [expr {30 * $charspc}] |
| set geometry(canv3) [expr {15 * $charspc}] |
| set geometry(canvh) [expr {25 * $linespc + 4}] |
| set geometry(ctextw) 80 |
| set geometry(ctexth) 30 |
| set geometry(cflistw) 30 |
| } |
| panedwindow .ctop -orient vertical |
| if {[info exists geometry(width)]} { |
| .ctop conf -width $geometry(width) -height $geometry(height) |
| set texth [expr {$geometry(height) - $geometry(canvh) - 56}] |
| set geometry(ctexth) [expr {($texth - 8) / |
| [font metrics $textfont -linespace]}] |
| } |
| frame .ctop.top |
| frame .ctop.top.bar |
| pack .ctop.top.bar -side bottom -fill x |
| set cscroll .ctop.top.csb |
| scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0 |
| pack $cscroll -side right -fill y |
| panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4 |
| pack .ctop.top.clist -side top -fill both -expand 1 |
| .ctop add .ctop.top |
| set canv .ctop.top.clist.canv |
| canvas $canv -height $geometry(canvh) -width $geometry(canv1) \ |
| -bg white -bd 0 \ |
| -yscrollincr $linespc -yscrollcommand "$cscroll set" |
| .ctop.top.clist add $canv |
| set canv2 .ctop.top.clist.canv2 |
| canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \ |
| -bg white -bd 0 -yscrollincr $linespc |
| .ctop.top.clist add $canv2 |
| set canv3 .ctop.top.clist.canv3 |
| canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \ |
| -bg white -bd 0 -yscrollincr $linespc |
| .ctop.top.clist add $canv3 |
| bind .ctop.top.clist <Configure> {resizeclistpanes %W %w} |
| |
| set sha1entry .ctop.top.bar.sha1 |
| set entries $sha1entry |
| set sha1but .ctop.top.bar.sha1label |
| button $sha1but -text "SHA1 ID: " -state disabled -relief flat \ |
| -command gotocommit -width 8 |
| $sha1but conf -disabledforeground [$sha1but cget -foreground] |
| pack .ctop.top.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 .ctop.top.bar.leftbut -image bm-left -command goback \ |
| -state disabled -width 26 |
| pack .ctop.top.bar.leftbut -side left -fill y |
| button .ctop.top.bar.rightbut -image bm-right -command goforw \ |
| -state disabled -width 26 |
| pack .ctop.top.bar.rightbut -side left -fill y |
| |
| button .ctop.top.bar.findbut -text "Find" -command dofind |
| pack .ctop.top.bar.findbut -side left |
| set findstring {} |
| set fstring .ctop.top.bar.findstring |
| lappend entries $fstring |
| entry $fstring -width 30 -font $textfont -textvariable findstring |
| pack $fstring -side left -expand 1 -fill x |
| set findtype Exact |
| set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \ |
| findtype Exact IgnCase Regexp] |
| set findloc "All fields" |
| tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \ |
| Comments Author Committer Files Pickaxe |
| pack .ctop.top.bar.findloc -side right |
| pack .ctop.top.bar.findtype -side right |
| # for making sure type==Exact whenever loc==Pickaxe |
| trace add variable findloc write findlocchange |
| |
| panedwindow .ctop.cdet -orient horizontal |
| .ctop add .ctop.cdet |
| frame .ctop.cdet.left |
| set ctext .ctop.cdet.left.ctext |
| text $ctext -bg white -state disabled -font $textfont \ |
| -width $geometry(ctextw) -height $geometry(ctexth) \ |
| -yscrollcommand ".ctop.cdet.left.sb set" -wrap none |
| scrollbar .ctop.cdet.left.sb -command "$ctext yview" |
| pack .ctop.cdet.left.sb -side right -fill y |
| pack $ctext -side left -fill both -expand 1 |
| .ctop.cdet add .ctop.cdet.left |
| |
| $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa" |
| $ctext tag conf hunksep -fore blue |
| $ctext tag conf d0 -fore red |
| $ctext tag conf d1 -fore "#00a000" |
| $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 mmax -fore darkgrey |
| set mergemax 5 |
| $ctext tag conf mresult -font [concat $textfont bold] |
| $ctext tag conf msep -font [concat $textfont bold] |
| $ctext tag conf found -back yellow |
| |
| frame .ctop.cdet.right |
| set cflist .ctop.cdet.right.cfiles |
| listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \ |
| -yscrollcommand ".ctop.cdet.right.sb set" |
| scrollbar .ctop.cdet.right.sb -command "$cflist yview" |
| pack .ctop.cdet.right.sb -side right -fill y |
| pack $cflist -side left -fill both -expand 1 |
| .ctop.cdet add .ctop.cdet.right |
| bind .ctop.cdet <Configure> {resizecdetpanes %W %w} |
| |
| pack .ctop -side top -fill both -expand 1 |
| |
| bindall <1> {selcanvline %W %x %y} |
| #bindall <B1-Motion> {selcanvline %W %x %y} |
| bindall <ButtonRelease-4> "allcanvs yview scroll -5 units" |
| bindall <ButtonRelease-5> "allcanvs yview scroll 5 units" |
| bindall <2> "allcanvs scan mark 0 %y" |
| bindall <B2-Motion> "allcanvs scan dragto 0 %y" |
| bind . <Key-Up> "selnextline -1" |
| bind . <Key-Down> "selnextline 1" |
| bind . <Key-Right> "goforw" |
| bind . <Key-Left> "goback" |
| bind . <Key-Prior> "allcanvs yview scroll -1 pages" |
| bind . <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 / {findnext 1} |
| bindkey <Key-Return> {findnext 0} |
| bindkey ? findprev |
| bindkey f nextfile |
| bind . <Control-q> doquit |
| bind . <Control-f> dofind |
| bind . <Control-g> {findnext 0} |
| bind . <Control-r> findprev |
| bind . <Control-equal> {incrfont 1} |
| bind . <Control-KP_Add> {incrfont 1} |
| bind . <Control-minus> {incrfont -1} |
| bind . <Control-KP_Subtract> {incrfont -1} |
| bind $cflist <<ListboxSelect>> listboxsel |
| bind . <Destroy> {savestuff %W} |
| bind . <Button-1> "click %W" |
| bind $fstring <Key-Return> dofind |
| bind $sha1entry <Key-Return> gotocommit |
| bind $sha1entry <<PasteSelection>> clearsha1 |
| |
| set maincursor [. cget -cursor] |
| set textcursor [$ctext cget -cursor] |
| set curtextcursor $textcursor |
| |
| set rowctxmenu .rowctxmenu |
| menu $rowctxmenu -tearoff 0 |
| $rowctxmenu add command -label "Diff this -> selected" \ |
| -command {diffvssel 0} |
| $rowctxmenu add command -label "Diff selected -> this" \ |
| -command {diffvssel 1} |
| $rowctxmenu add command -label "Make patch" -command mkpatch |
| $rowctxmenu add command -label "Create tag" -command mktag |
| $rowctxmenu add command -label "Write commit to file" -command writecommit |
| } |
| |
| # 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 entries |
| foreach e $entries { |
| if {$w == $e} return |
| } |
| focus . |
| } |
| |
| proc savestuff {w} { |
| global canv canv2 canv3 ctext cflist mainfont textfont |
| global stuffsaved findmergefiles maxgraphpct |
| global maxwidth |
| |
| 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 findmergefiles $findmergefiles] |
| puts $f [list set maxgraphpct $maxgraphpct] |
| puts $f [list set maxwidth $maxwidth] |
| puts $f "set geometry(width) [winfo width .ctop]" |
| puts $f "set geometry(height) [winfo height .ctop]" |
| puts $f "set geometry(canv1) [expr {[winfo width $canv]-2}]" |
| puts $f "set geometry(canv2) [expr {[winfo width $canv2]-2}]" |
| puts $f "set geometry(canv3) [expr {[winfo width $canv3]-2}]" |
| puts $f "set geometry(canvh) [expr {[winfo height $canv]-2}]" |
| set wid [expr {([winfo width $ctext] - 8) \ |
| / [font measure $textfont "0"]}] |
| puts $f "set geometry(ctextw) $wid" |
| set wid [expr {([winfo width $cflist] - 11) \ |
| / [font measure [$cflist cget -font] "0"]}] |
| puts $f "set geometry(cflistw) $wid" |
| 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 {} { |
| set w .about |
| if {[winfo exists $w]} { |
| raise $w |
| return |
| } |
| toplevel $w |
| wm title $w "About gitk" |
| message $w.m -text { |
| Gitk version 1.2 |
| |
| Copyright © 2005 Paul Mackerras |
| |
| Use and redistribute under the terms of the GNU General Public License} \ |
| -justify center -aspect 400 |
| pack $w.m -side top -fill x -padx 20 -pady 20 |
| button $w.ok -text Close -command "destroy $w" |
| pack $w.ok -side bottom |
| } |
| |
| proc assigncolor {id} { |
| global colormap commcolors colors nextcolor |
| global parents nparents children nchildren |
| global cornercrossings crossings |
| |
| if [info exists colormap($id)] return |
| set ncolors [llength $colors] |
| if {$nparents($id) <= 1 && $nchildren($id) == 1} { |
| set child [lindex $children($id) 0] |
| if {[info exists colormap($child)] |
| && $nparents($child) == 1} { |
| set colormap($id) $colormap($child) |
| return |
| } |
| } |
| set badcolors {} |
| if {[info exists cornercrossings($id)]} { |
| foreach x $cornercrossings($id) { |
| if {[info exists colormap($x)] |
| && [lsearch -exact $badcolors $colormap($x)] < 0} { |
| lappend badcolors $colormap($x) |
| } |
| } |
| if {[llength $badcolors] >= $ncolors} { |
| set badcolors {} |
| } |
| } |
| set origbad $badcolors |
| if {[llength $badcolors] < $ncolors - 1} { |
| if {[info exists crossings($id)]} { |
| foreach x $crossings($id) { |
| if {[info exists colormap($x)] |
| && [lsearch -exact $badcolors $colormap($x)] < 0} { |
| lappend badcolors $colormap($x) |
| } |
| } |
| if {[llength $badcolors] >= $ncolors} { |
| set badcolors $origbad |
| } |
| } |
| set origbad $badcolors |
| } |
| if {[llength $badcolors] < $ncolors - 1} { |
| foreach child $children($id) { |
| if {[info exists colormap($child)] |
| && [lsearch -exact $badcolors $colormap($child)] < 0} { |
| lappend badcolors $colormap($child) |
| } |
| if {[info exists parents($child)]} { |
| foreach p $parents($child) { |
| if {[info exists colormap($p)] |
| && [lsearch -exact $badcolors $colormap($p)] < 0} { |
| lappend badcolors $colormap($p) |
| } |
| } |
| } |
| } |
| if {[llength $badcolors] >= $ncolors} { |
| set badcolors $origbad |
| } |
| } |
| for {set i 0} {$i <= $ncolors} {incr i} { |
| set c [lindex $colors $nextcolor] |
| if {[incr nextcolor] >= $ncolors} { |
| set nextcolor 0 |
| } |
| if {[lsearch -exact $badcolors $c]} break |
| } |
| set colormap($id) $c |
| } |
| |
| proc initgraph {} { |
| global canvy canvy0 lineno numcommits nextcolor linespc |
| global nchildren ncleft |
| global displist nhyperspace |
| |
| allcanvs delete all |
| set nextcolor 0 |
| set canvy $canvy0 |
| set lineno -1 |
| set numcommits 0 |
| foreach v {mainline mainlinearrow sidelines colormap cornercrossings |
| crossings idline lineid} { |
| global $v |
| catch {unset $v} |
| } |
| foreach id [array names nchildren] { |
| set ncleft($id) $nchildren($id) |
| } |
| set displist {} |
| set nhyperspace 0 |
| } |
| |
| proc bindline {t id} { |
| global canv |
| |
| $canv bind $t <Enter> "lineenter %x %y $id" |
| $canv bind $t <Motion> "linemotion %x %y $id" |
| $canv bind $t <Leave> "lineleave $id" |
| $canv bind $t <Button-1> "lineclick %x %y $id 1" |
| } |
| |
| proc drawlines {id xtra delold} { |
| global mainline mainlinearrow sidelines lthickness colormap canv |
| |
| if {$delold} { |
| $canv delete lines.$id |
| } |
| if {[info exists mainline($id)]} { |
| set t [$canv create line $mainline($id) \ |
| -width [expr {($xtra + 1) * $lthickness}] \ |
| -fill $colormap($id) -tags lines.$id \ |
| -arrow $mainlinearrow($id)] |
| $canv lower $t |
| bindline $t $id |
| } |
| if {[info exists sidelines($id)]} { |
| foreach ls $sidelines($id) { |
| set coords [lindex $ls 0] |
| set thick [lindex $ls 1] |
| set arrow [lindex $ls 2] |
| set t [$canv create line $coords -fill $colormap($id) \ |
| -width [expr {($thick + $xtra) * $lthickness}] \ |
| -arrow $arrow -tags lines.$id] |
| $canv lower $t |
| bindline $t $id |
| } |
| } |
| } |
| |
| # level here is an index in displist |
| proc drawcommitline {level} { |
| global parents children nparents displist |
| global canv canv2 canv3 mainfont namefont canvy linespc |
| global lineid linehtag linentag linedtag commitinfo |
| global colormap numcommits currentparents dupparents |
| global idtags idline idheads idotherrefs |
| global lineno lthickness mainline mainlinearrow sidelines |
| global commitlisted rowtextx idpos lastuse displist |
| global oldnlines olddlevel olddisplist |
| |
| incr numcommits |
| incr lineno |
| set id [lindex $displist $level] |
| set lastuse($id) $lineno |
| set lineid($lineno) $id |
| set idline($id) $lineno |
| set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}] |
| if {![info exists commitinfo($id)]} { |
| readcommit $id |
| if {![info exists commitinfo($id)]} { |
| set commitinfo($id) {"No commit information available"} |
| set nparents($id) 0 |
| } |
| } |
| assigncolor $id |
| set currentparents {} |
| set dupparents {} |
| if {[info exists commitlisted($id)] && [info exists parents($id)]} { |
| foreach p $parents($id) { |
| if {[lsearch -exact $currentparents $p] < 0} { |
| lappend currentparents $p |
| } else { |
| # remember that this parent was listed twice |
| lappend dupparents $p |
| } |
| } |
| } |
| set x [xcoord $level $level $lineno] |
| set y1 $canvy |
| set canvy [expr {$canvy + $linespc}] |
| allcanvs conf -scrollregion \ |
| [list 0 0 0 [expr {$y1 + 0.5 * $linespc + 2}]] |
| if {[info exists mainline($id)]} { |
| lappend mainline($id) $x $y1 |
| if {$mainlinearrow($id) ne "none"} { |
| set mainline($id) [trimdiagstart $mainline($id)] |
| } |
| } |
| drawlines $id 0 0 |
| set orad [expr {$linespc / 3}] |
| set t [$canv create oval [expr {$x - $orad}] [expr {$y1 - $orad}] \ |
| [expr {$x + $orad - 1}] [expr {$y1 + $orad - 1}] \ |
| -fill $ofill -outline black -width 1] |
| $canv raise $t |
| $canv bind $t <1> {selcanvline {} %x %y} |
| set xt [xcoord [llength $displist] $level $lineno] |
| if {[llength $currentparents] > 2} { |
| set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}] |
| } |
| set rowtextx($lineno) $xt |
| set idpos($id) [list $x $xt $y1] |
| if {[info exists idtags($id)] || [info exists idheads($id)] |
| || [info exists idotherrefs($id)]} { |
| set xt [drawtags $id $x $xt $y1] |
| } |
| set headline [lindex $commitinfo($id) 0] |
| set name [lindex $commitinfo($id) 1] |
| set date [lindex $commitinfo($id) 2] |
| set date [formatdate $date] |
| set linehtag($lineno) [$canv create text $xt $y1 -anchor w \ |
| -text $headline -font $mainfont ] |
| $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id" |
| set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \ |
| -text $name -font $namefont] |
| set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \ |
| -text $date -font $mainfont] |
| |
| set olddlevel $level |
| set olddisplist $displist |
| set oldnlines [llength $displist] |
| } |
| |
| proc drawtags {id x xt y1} { |
| global idtags idheads idotherrefs |
| global linespc lthickness |
| global canv mainfont idline rowtextx |
| |
| set marks {} |
| set ntags 0 |
| set nheads 0 |
| if {[info exists idtags($id)]} { |
| set marks $idtags($id) |
| set ntags [llength $marks] |
| } |
| if {[info exists idheads($id)]} { |
| set marks [concat $marks $idheads($id)] |
| set nheads [llength $idheads($id)] |
| } |
| if {[info exists idotherrefs($id)]} { |
| set marks [concat $marks $idotherrefs($id)] |
| } |
| if {$marks eq {}} { |
| return $xt |
| } |
| |
| set delta [expr {int(0.5 * ($linespc - $lthickness))}] |
| set yt [expr {$y1 - 0.5 * $linespc}] |
| set yb [expr {$yt + $linespc - 1}] |
| set xvals {} |
| set wvals {} |
| foreach tag $marks { |
| set wid [font measure $mainfont $tag] |
| lappend xvals $xt |
| lappend wvals $wid |
| set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}] |
| } |
| set t [$canv create line $x $y1 [lindex $xvals end] $y1 \ |
| -width $lthickness -fill black -tags tag.$id] |
| $canv lower $t |
| foreach tag $marks x $xvals wid $wvals { |
| set xl [expr {$x + $delta}] |
| set xr [expr {$x + $delta + $wid + $lthickness}] |
| if {[incr ntags -1] >= 0} { |
| # draw a tag |
| set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \ |
| $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \ |
| -width 1 -outline black -fill yellow -tags tag.$id] |
| $canv bind $t <1> [list showtag $tag 1] |
| set rowtextx($idline($id)) [expr {$xr + $linespc}] |
| } else { |
| # draw a head or other ref |
| if {[incr nheads -1] >= 0} { |
| set col green |
| } else { |
| set col "#ddddff" |
| } |
| set xl [expr {$xl - $delta/2}] |
| $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \ |
| -width 1 -outline black -fill $col -tags tag.$id |
| } |
| set t [$canv create text $xl $y1 -anchor w -text $tag \ |
| -font $mainfont -tags tag.$id] |
| if {$ntags >= 0} { |
| $canv bind $t <1> [list showtag $tag 1] |
| } |
| } |
| return $xt |
| } |
| |
| proc notecrossings {id lo hi corner} { |
| global olddisplist crossings cornercrossings |
| |
| for {set i $lo} {[incr i] < $hi} {} { |
| set p [lindex $olddisplist $i] |
| if {$p == {}} continue |
| if {$i == $corner} { |
| if {![info exists cornercrossings($id)] |
| || [lsearch -exact $cornercrossings($id) $p] < 0} { |
| lappend cornercrossings($id) $p |
| } |
| if {![info exists cornercrossings($p)] |
| || [lsearch -exact $cornercrossings($p) $id] < 0} { |
| lappend cornercrossings($p) $id |
| } |
| } else { |
| if {![info exists crossings($id)] |
| || [lsearch -exact $crossings($id) $p] < 0} { |
| lappend crossings($id) $p |
| } |
| if {![info exists crossings($p)] |
| || [lsearch -exact $crossings($p) $id] < 0} { |
| lappend crossings($p) $id |
| } |
| } |
| } |
| } |
| |
| proc xcoord {i level ln} { |
| global canvx0 xspc1 xspc2 |
| |
| set x [expr {$canvx0 + $i * $xspc1($ln)}] |
| if {$i > 0 && $i == $level} { |
| set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}] |
| } elseif {$i > $level} { |
| set x [expr {$x + $xspc2 - $xspc1($ln)}] |
| } |
| return $x |
| } |
| |
| # it seems Tk can't draw arrows on the end of diagonal line segments... |
| proc trimdiagend {line} { |
| while {[llength $line] > 4} { |
| set x1 [lindex $line end-3] |
| set y1 [lindex $line end-2] |
| set x2 [lindex $line end-1] |
| set y2 [lindex $line end] |
| if {($x1 == $x2) != ($y1 == $y2)} break |
| set line [lreplace $line end-1 end] |
| } |
| return $line |
| } |
| |
| proc trimdiagstart {line} { |
| while {[llength $line] > 4} { |
| set x1 [lindex $line 0] |
| set y1 [lindex $line 1] |
| set x2 [lindex $line 2] |
| set y2 [lindex $line 3] |
| if {($x1 == $x2) != ($y1 == $y2)} break |
| set line [lreplace $line 0 1] |
| } |
| return $line |
| } |
| |
| proc drawslants {id needonscreen nohs} { |
| global canv mainline mainlinearrow sidelines |
| global canvx0 canvy xspc1 xspc2 lthickness |
| global currentparents dupparents |
| global lthickness linespc canvy colormap lineno geometry |
| global maxgraphpct maxwidth |
| global displist onscreen lastuse |
| global parents commitlisted |
| global oldnlines olddlevel olddisplist |
| global nhyperspace numcommits nnewparents |
| |
| if {$lineno < 0} { |
| lappend displist $id |
| set onscreen($id) 1 |
| return 0 |
| } |
| |
| set y1 [expr {$canvy - $linespc}] |
| set y2 $canvy |
| |
| # work out what we need to get back on screen |
| set reins {} |
| if {$onscreen($id) < 0} { |
| # next to do isn't displayed, better get it on screen... |
| lappend reins [list $id 0] |
| } |
| # make sure all the previous commits's parents are on the screen |
| foreach p $currentparents { |
| if {$onscreen($p) < 0} { |
| lappend reins [list $p 0] |
| } |
| } |
| # bring back anything requested by caller |
| if {$needonscreen ne {}} { |
| lappend reins $needonscreen |
| } |
| |
| # try the shortcut |
| if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} { |
| set dlevel $olddlevel |
| set x [xcoord $dlevel $dlevel $lineno] |
| set mainline($id) [list $x $y1] |
| set mainlinearrow($id) none |
| set lastuse($id) $lineno |
| set displist [lreplace $displist $dlevel $dlevel $id] |
| set onscreen($id) 1 |
| set xspc1([expr {$lineno + 1}]) $xspc1($lineno) |
| return $dlevel |
| } |
| |
| # update displist |
| set displist [lreplace $displist $olddlevel $olddlevel] |
| set j $olddlevel |
| foreach p $currentparents { |
| set lastuse($p) $lineno |
| if {$onscreen($p) == 0} { |
| set displist [linsert $displist $j $p] |
| set onscreen($p) 1 |
| incr j |
| } |
| } |
| if {$onscreen($id) == 0} { |
| lappend displist $id |
| set onscreen($id) 1 |
| } |
| |
| # remove the null entry if present |
| set nullentry [lsearch -exact $displist {}] |
| if {$nullentry >= 0} { |
| set displist [lreplace $displist $nullentry $nullentry] |
| } |
| |
| # bring back the ones we need now (if we did it earlier |
| # it would change displist and invalidate olddlevel) |
| foreach pi $reins { |
| # test again in case of duplicates in reins |
| set p [lindex $pi 0] |
| if {$onscreen($p) < 0} { |
| set onscreen($p) 1 |
| set lastuse($p) $lineno |
| set displist [linsert $displist [lindex $pi 1] $p] |
| incr nhyperspace -1 |
| } |
| } |
| |
| set lastuse($id) $lineno |
| |
| # see if we need to make any lines jump off into hyperspace |
| set displ [llength $displist] |
| if {$displ > $maxwidth} { |
| set ages {} |
| foreach x $displist { |
| lappend ages [list $lastuse($x) $x] |
| } |
| set ages [lsort -integer -index 0 $ages] |
| set k 0 |
| while {$displ > $maxwidth} { |
| set use [lindex $ages $k 0] |
| set victim [lindex $ages $k 1] |
| if {$use >= $lineno - 5} break |
| incr k |
| if {[lsearch -exact $nohs $victim] >= 0} continue |
| set i [lsearch -exact $displist $victim] |
| set displist [lreplace $displist $i $i] |
| set onscreen($victim) -1 |
| incr nhyperspace |
| incr displ -1 |
| if {$i < $nullentry} { |
| incr nullentry -1 |
| } |
| set x [lindex $mainline($victim) end-1] |
| lappend mainline($victim) $x $y1 |
| set line [trimdiagend $mainline($victim)] |
| set arrow "last" |
| if {$mainlinearrow($victim) ne "none"} { |
| set line [trimdiagstart $line] |
| set arrow "both" |
| } |
| lappend sidelines($victim) [list $line 1 $arrow] |
| unset mainline($victim) |
| } |
| } |
| |
| set dlevel [lsearch -exact $displist $id] |
| |
| # If we are reducing, put in a null entry |
| if {$displ < $oldnlines} { |
| # does the next line look like a merge? |
| # i.e. does it have > 1 new parent? |
| if {$nnewparents($id) > 1} { |
| set i [expr {$dlevel + 1}] |
| } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} { |
| set i $olddlevel |
| if {$nullentry >= 0 && $nullentry < $i} { |
| incr i -1 |
| } |
| } elseif {$nullentry >= 0} { |
| set i $nullentry |
| while {$i < $displ |
| && [lindex $olddisplist $i] == [lindex $displist $i]} { |
| incr i |
| } |
| } else { |
| set i $olddlevel |
| if {$dlevel >= $i} { |
| incr i |
| } |
| } |
| if {$i < $displ} { |
| set displist [linsert $displist $i {}] |
| incr displ |
| if {$dlevel >= $i} { |
| incr dlevel |
| } |
| } |
| } |
| |
| # decide on the line spacing for the next line |
| set lj [expr {$lineno + 1}] |
| set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}] |
| if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} { |
| set xspc1($lj) $xspc2 |
| } else { |
| set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}] |
| if {$xspc1($lj) < $lthickness} { |
| set xspc1($lj) $lthickness |
| } |
| } |
| |
| foreach idi $reins { |
| set id [lindex $idi 0] |
| set j [lsearch -exact $displist $id] |
| set xj [xcoord $j $dlevel $lj] |
| set mainline($id) [list $xj $y2] |
| set mainlinearrow($id) first |
| } |
| |
| set i -1 |
| foreach id $olddisplist { |
| incr i |
| if {$id == {}} continue |
| if {$onscreen($id) <= 0} continue |
| set xi [xcoord $i $olddlevel $lineno] |
| if {$i == $olddlevel} { |
| foreach p $currentparents { |
| set j [lsearch -exact $displist $p] |
| set coords [list $xi $y1] |
| set xj [xcoord $j $dlevel $lj] |
| if {$xj < $xi - $linespc} { |
| lappend coords [expr {$xj + $linespc}] $y1 |
| notecrossings $p $j $i [expr {$j + 1}] |
| } elseif {$xj > $xi + $linespc} { |
| lappend coords [expr {$xj - $linespc}] $y1 |
| notecrossings $p $i $j [expr {$j - 1}] |
| } |
| if {[lsearch -exact $dupparents $p] >= 0} { |
| # draw a double-width line to indicate the doubled parent |
| lappend coords $xj $y2 |
| lappend sidelines($p) [list $coords 2 none] |
| if {![info exists mainline($p)]} { |
| set mainline($p) [list $xj $y2] |
| set mainlinearrow($p) none |
| } |
| } else { |
| # normal case, no parent duplicated |
| set yb $y2 |
| set dx [expr {abs($xi - $xj)}] |
| if {0 && $dx < $linespc} { |
| set yb [expr {$y1 + $dx}] |
| } |
| if {![info exists mainline($p)]} { |
| if {$xi != $xj} { |
| lappend coords $xj $yb |
| } |
| set mainline($p) $coords |
| set mainlinearrow($p) none |
| } else { |
| lappend coords $xj $yb |
| if {$yb < $y2} { |
| lappend coords $xj $y2 |
| } |
| lappend sidelines($p) [list $coords 1 none] |
| } |
| } |
| } |
| } else { |
| set j $i |
| if {[lindex $displist $i] != $id} { |
| set j [lsearch -exact $displist $id] |
| } |
| if {$j != $i || $xspc1($lineno) != $xspc1($lj) |
| || ($olddlevel < $i && $i < $dlevel) |
| || ($dlevel < $i && $i < $olddlevel)} { |
| set xj [xcoord $j $dlevel $lj] |
| lappend mainline($id) $xi $y1 $xj $y2 |
| } |
| } |
| } |
| return $dlevel |
| } |
| |
| # search for x in a list of lists |
| proc llsearch {llist x} { |
| set i 0 |
| foreach l $llist { |
| if {$l == $x || [lsearch -exact $l $x] >= 0} { |
| return $i |
| } |
| incr i |
| } |
| return -1 |
| } |
| |
| proc drawmore {reading} { |
| global displayorder numcommits ncmupdate nextupdate |
| global stopped nhyperspace parents commitlisted |
| global maxwidth onscreen displist currentparents olddlevel |
| |
| set n [llength $displayorder] |
| while {$numcommits < $n} { |
| set id [lindex $displayorder $numcommits] |
| set ctxend [expr {$numcommits + 10}] |
| if {!$reading && $ctxend > $n} { |
| set ctxend $n |
| } |
| set dlist {} |
| if {$numcommits > 0} { |
| set dlist [lreplace $displist $olddlevel $olddlevel] |
| set i $olddlevel |
| foreach p $currentparents { |
| if {$onscreen($p) == 0} { |
| set dlist [linsert $dlist $i $p] |
| incr i |
| } |
| } |
| } |
| set nohs {} |
| set reins {} |
| set isfat [expr {[llength $dlist] > $maxwidth}] |
| if {$nhyperspace > 0 || $isfat} { |
| if {$ctxend > $n} break |
| # work out what to bring back and |
| # what we want to don't want to send into hyperspace |
| set room 1 |
| for {set k $numcommits} {$k < $ctxend} {incr k} { |
| set x [lindex $displayorder $k] |
| set i [llsearch $dlist $x] |
| if {$i < 0} { |
| set i [llength $dlist] |
| lappend dlist $x |
| } |
| if {[lsearch -exact $nohs $x] < 0} { |
| lappend nohs $x |
| } |
| if {$reins eq {} && $onscreen($x) < 0 && $room} { |
| set reins [list $x $i] |
| } |
| set newp {} |
| if {[info exists commitlisted($x)]} { |
| set right 0 |
| foreach p $parents($x) { |
| if {[llsearch $dlist $p] < 0} { |
| lappend newp $p |
| if {[lsearch -exact $nohs $p] < 0} { |
| lappend nohs $p |
| } |
| if {$reins eq {} && $onscreen($p) < 0 && $room} { |
| set reins [list $p [expr {$i + $right}]] |
| } |
| } |
| set right 1 |
| } |
| } |
| set l [lindex $dlist $i] |
| if {[llength $l] == 1} { |
| set l $newp |
| } else { |
| set j [lsearch -exact $l $x] |
| set l [concat [lreplace $l $j $j] $newp] |
| } |
| set dlist [lreplace $dlist $i $i $l] |
| if {$room && $isfat && [llength $newp] <= 1} { |
| set room 0 |
| } |
| } |
| } |
| |
| set dlevel [drawslants $id $reins $nohs] |
| drawcommitline $dlevel |
| if {[clock clicks -milliseconds] >= $nextupdate |
| && $numcommits >= $ncmupdate} { |
| doupdate $reading |
| if {$stopped} break |
| } |
| } |
| } |
| |
| # level here is an index in todo |
| proc updatetodo {level noshortcut} { |
| global ncleft todo nnewparents |
| global commitlisted parents onscreen |
| |
| set id [lindex $todo $level] |
| set olds {} |
| if {[info exists commitlisted($id)]} { |
| foreach p $parents($id) { |
| if {[lsearch -exact $olds $p] < 0} { |
| lappend olds $p |
| } |
| } |
| } |
| if {!$noshortcut && [llength $olds] == 1} { |
| set p [lindex $olds 0] |
| if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} { |
| set ncleft($p) 0 |
| set todo [lreplace $todo $level $level $p] |
| set onscreen($p) 0 |
| set nnewparents($id) 1 |
| return 0 |
| } |
| } |
| |
| set todo [lreplace $todo $level $level] |
| set i $level |
| set n 0 |
| foreach p $olds { |
| incr ncleft($p) -1 |
| set k [lsearch -exact $todo $p] |
| if {$k < 0} { |
| set todo [linsert $todo $i $p] |
| set onscreen($p) 0 |
| incr i |
| incr n |
| } |
| } |
| set nnewparents($id) $n |
| |
| return 1 |
| } |
| |
| proc decidenext {{noread 0}} { |
| global ncleft todo |
| global datemode cdate |
| global commitinfo |
| |
| # choose which one to do next time around |
| set todol [llength $todo] |
| set level -1 |
| set latest {} |
| for {set k $todol} {[incr k -1] >= 0} {} { |
| set p [lindex $todo $k] |
| if {$ncleft($p) == 0} { |
| if {$datemode} { |
| if {![info exists commitinfo($p)]} { |
| if {$noread} { |
| return {} |
| } |
| readcommit $p |
| } |
| if {$latest == {} || $cdate($p) > $latest} { |
| set level $k |
| set latest $cdate($p) |
| } |
| } else { |
| set level $k |
| break |
| } |
| } |
| } |
| |
| return $level |
| } |
| |
| proc drawcommit {id reading} { |
| global phase todo nchildren datemode nextupdate revlistorder ncleft |
| global numcommits ncmupdate displayorder todo onscreen parents |
| global commitlisted commitordered |
| |
| if {$phase != "incrdraw"} { |
| set phase incrdraw |
| set displayorder {} |
| set todo {} |
| initgraph |
| catch {unset commitordered} |
| } |
| set commitordered($id) 1 |
| if {$nchildren($id) == 0} { |
| lappend todo $id |
| set onscreen($id) 0 |
| } |
| if {$revlistorder} { |
| set level [lsearch -exact $todo $id] |
| if {$level < 0} { |
| error_popup "oops, $id isn't in todo" |
| return |
| } |
| lappend displayorder $id |
| updatetodo $level 0 |
| } else { |
| set level [decidenext 1] |
| if {$level == {} || $level < 0} return |
| while 1 { |
| set id [lindex $todo $level] |
| if {![info exists commitordered($id)]} { |
| break |
| } |
| lappend displayorder [lindex $todo $level] |
| if {[updatetodo $level $datemode]} { |
| set level [decidenext 1] |
| if {$level == {} || $level < 0} break |
| } |
| } |
| } |
| drawmore $reading |
| } |
| |
| proc finishcommits {} { |
| global phase oldcommits commits |
| global canv mainfont ctext maincursor textcursor |
| global parents displayorder todo |
| |
| if {$phase == "incrdraw" || $phase == "removecommits"} { |
| foreach id $oldcommits { |
| lappend commits $id |
| drawcommit $id 0 |
| } |
| set oldcommits {} |
| drawrest |
| } elseif {$phase == "updatecommits"} { |
| # there were no new commits, in fact |
| set commits $oldcommits |
| set oldcommits {} |
| set phase {} |
| } else { |
| $canv delete all |
| $canv create text 3 3 -anchor nw -text "No commits selected" \ |
| -font $mainfont -tags textitems |
| set phase {} |
| } |
| . config -cursor $maincursor |
| settextcursor $textcursor |
| } |
| |
| # Don't change the text pane cursor if it is currently the hand cursor, |
| # showing that we are over a sha1 ID link. |
| proc settextcursor {c} { |
| global ctext curtextcursor |
| |
| if {[$ctext cget -cursor] == $curtextcursor} { |
| $ctext config -cursor $c |
| } |
| set curtextcursor $c |
| } |
| |
| proc drawgraph {} { |
| global nextupdate startmsecs ncmupdate |
| global displayorder onscreen |
| |
| if {$displayorder == {}} return |
| set startmsecs [clock clicks -milliseconds] |
| set nextupdate [expr {$startmsecs + 100}] |
| set ncmupdate 1 |
| initgraph |
| foreach id $displayorder { |
| set onscreen($id) 0 |
| } |
| drawmore 0 |
| } |
| |
| proc drawrest {} { |
| global phase stopped redisplaying selectedline |
| global datemode todo displayorder ncleft |
| global numcommits ncmupdate |
| global nextupdate startmsecs revlistorder |
| |
| set level [decidenext] |
| if {$level >= 0} { |
| set phase drawgraph |
| while 1 { |
| lappend displayorder [lindex $todo $level] |
| set hard [updatetodo $level $datemode] |
| if {$hard} { |
| set level [decidenext] |
| if {$level < 0} break |
| } |
| } |
| } |
| if {$todo != {}} { |
| puts "ERROR: none of the pending commits can be done yet:" |
| foreach p $todo { |
| puts " $p ($ncleft($p))" |
| } |
| } |
| |
| drawmore 0 |
| set phase {} |
| set drawmsecs [expr {[clock clicks -milliseconds] - $startmsecs}] |
| #puts "overall $drawmsecs ms for $numcommits commits" |
| if {$redisplaying} { |
| if {$stopped == 0 && [info exists selectedline]} { |
| selectline $selectedline 0 |
| } |
| if {$stopped == 1} { |
| set stopped 0 |
| after idle drawgraph |
| } else { |
| set redisplaying 0 |
| } |
| } |
| } |
| |
| proc findmatches {f} { |
| global findtype foundstring foundstrlen |
| if {$findtype == "Regexp"} { |
| set matches [regexp -indices -all -inline $foundstring $f] |
| } else { |
| if {$findtype == "IgnCase"} { |
| set str [string tolower $f] |
| } else { |
| set str $f |
| } |
| set matches {} |
| set i 0 |
| while {[set j [string first $foundstring $str $i]] >= 0} { |
| lappend matches [list $j [expr {$j+$foundstrlen-1}]] |
| set i [expr {$j + $foundstrlen}] |
| } |
| } |
| return $matches |
| } |
| |
| proc dofind {} { |
| global findtype findloc findstring markedmatches commitinfo |
| global numcommits lineid linehtag linentag linedtag |
| global mainfont namefont canv canv2 canv3 selectedline |
| global matchinglines foundstring foundstrlen |
| |
| stopfindproc |
| unmarkmatches |
| focus . |
| set matchinglines {} |
| if {$findloc == "Pickaxe"} { |
| findpatches |
| return |
| } |
| if {$findtype == "IgnCase"} { |
| set foundstring [string tolower $findstring] |
| } else { |
| set foundstring $findstring |
| } |
| set foundstrlen [string length $findstring] |
| if {$foundstrlen == 0} return |
| if {$findloc == "Files"} { |
| findfiles |
| return |
| } |
| if {![info exists selectedline]} { |
| set oldsel -1 |
| } else { |
| set oldsel $selectedline |
| } |
| set didsel 0 |
| set fldtypes {Headline Author Date Committer CDate Comment} |
| for {set l 0} {$l < $numcommits} {incr l} { |
| set id $lineid($l) |
| set info $commitinfo($id) |
| set doesmatch 0 |
| foreach f $info ty $fldtypes { |
| if {$findloc != "All fields" && $findloc != $ty} { |
| continue |
| } |
| set matches [findmatches $f] |
| if {$matches == {}} continue |
| set doesmatch 1 |
| if {$ty == "Headline"} { |
| markmatches $canv $l $f $linehtag($l) $matches $mainfont |
| } elseif {$ty == "Author"} { |
| markmatches $canv2 $l $f $linentag($l) $matches $namefont |
| } elseif {$ty == "Date"} { |
| markmatches $canv3 $l $f $linedtag($l) $matches $mainfont |
| } |
| } |
| if {$doesmatch} { |
| lappend matchinglines $l |
| if {!$didsel && $l > $oldsel} { |
| findselectline $l |
| set didsel 1 |
| } |
| } |
| } |
| if {$matchinglines == {}} { |
| bell |
| } elseif {!$didsel} { |
| findselectline [lindex $matchinglines 0] |
| } |
| } |
| |
| proc findselectline {l} { |
| global findloc commentend ctext |
| selectline $l 1 |
| if {$findloc == "All fields" || $findloc == "Comments"} { |
| # highlight the matches in the comments |
| set f [$ctext get 1.0 $commentend] |
| set matches [findmatches $f] |
| foreach match $matches { |
| set start [lindex $match 0] |
| set end [expr {[lindex $match 1] + 1}] |
| $ctext tag add found "1.0 + $start c" "1.0 + $end c" |
| } |
| } |
| } |
| |
| proc findnext {restart} { |
| global matchinglines selectedline |
| if {![info exists matchinglines]} { |
| if {$restart} { |
| dofind |
| } |
| return |
| } |
| if {![info exists selectedline]} return |
| foreach l $matchinglines { |
| if {$l > $selectedline} { |
| findselectline $l |
| return |
| } |
| } |
| bell |
| } |
| |
| proc findprev {} { |
| global matchinglines selectedline |
| if {![info exists matchinglines]} { |
| dofind |
| return |
| } |
| if {![info exists selectedline]} return |
| set prev {} |
| foreach l $matchinglines { |
| if {$l >= $selectedline} break |
| set prev $l |
| } |
| if {$prev != {}} { |
| findselectline $prev |
| } else { |
| bell |
| } |
| } |
| |
| proc findlocchange {name ix op} { |
| global findloc findtype findtypemenu |
| if {$findloc == "Pickaxe"} { |
| set findtype Exact |
| set state disabled |
| } else { |
| set state normal |
| } |
| $findtypemenu entryconf 1 -state $state |
| $findtypemenu entryconf 2 -state $state |
| } |
| |
| proc stopfindproc {{done 0}} { |
| global findprocpid findprocfile findids |
| global ctext findoldcursor phase maincursor textcursor |
| global findinprogress |
| |
| catch {unset findids} |
| if {[info exists findprocpid]} { |
| if {!$done} { |
| catch {exec kill $findprocpid} |
| } |
| catch {close $findprocfile} |
| unset findprocpid |
| } |
| if {[info exists findinprogress]} { |
| unset findinprogress |
| if {$phase != "incrdraw"} { |
| . config -cursor $maincursor |
| settextcursor $textcursor |
| } |
| } |
| } |
| |
| proc findpatches {} { |
| global findstring selectedline numcommits |
| global findprocpid findprocfile |
| global finddidsel ctext lineid findinprogress |
| global findinsertpos |
| |
| if {$numcommits == 0} return |
| |
| # make a list of all the ids to search, starting at the one |
| # after the selected line (if any) |
| if {[info exists selectedline]} { |
| set l $selectedline |
| } else { |
| set l -1 |
| } |
| set inputids {} |
| for {set i 0} {$i < $numcommits} {incr i} { |
| if {[incr l] >= $numcommits} { |
| set l 0 |
| } |
| append inputids $lineid($l) "\n" |
| } |
| |
| if {[catch { |
| set f [open [list | git-diff-tree --stdin -s -r -S$findstring \ |
| << $inputids] r] |
| } err]} { |
| error_popup "Error starting search process: $err" |
| return |
| } |
| |
| set findinsertpos end |
| set findprocfile $f |
| set findprocpid [pid $f] |
| fconfigure $f -blocking 0 |
| fileevent $f readable readfindproc |
| set finddidsel 0 |
| . config -cursor watch |
| settextcursor watch |
| set findinprogress 1 |
| } |
| |
| proc readfindproc {} { |
| global findprocfile finddidsel |
| global idline matchinglines findinsertpos |
| |
| set n [gets $findprocfile line] |
| if {$n < 0} { |
| if {[eof $findprocfile]} { |
| stopfindproc 1 |
| if {!$finddidsel} { |
| bell |
| } |
| } |
| return |
| } |
| if {![regexp {^[0-9a-f]{40}} $line id]} { |
| error_popup "Can't parse git-diff-tree output: $line" |
| stopfindproc |
| return |
| } |
| if {![info exists idline($id)]} { |
| puts stderr "spurious id: $id" |
| return |
| } |
| set l $idline($id) |
| insertmatch $l $id |
| } |
| |
| proc insertmatch {l id} { |
| global matchinglines findinsertpos finddidsel |
| |
| if {$findinsertpos == "end"} { |
| if {$matchinglines != {} && $l < [lindex $matchinglines 0]} { |
| set matchinglines [linsert $matchinglines 0 $l] |
| set findinsertpos 1 |
| } else { |
| lappend matchinglines $l |
| } |
| } else { |
| set matchinglines [linsert $matchinglines $findinsertpos $l] |
| incr findinsertpos |
| } |
| markheadline $l $id |
| if {!$finddidsel} { |
| findselectline $l |
| set finddidsel 1 |
| } |
| } |
| |
| proc findfiles {} { |
| global selectedline numcommits lineid ctext |
| global ffileline finddidsel parents nparents |
| global findinprogress findstartline findinsertpos |
| global treediffs fdiffids fdiffsneeded fdiffpos |
| global findmergefiles |
| |
| if {$numcommits == 0} return |
| |
| if {[info exists selectedline]} { |
| set l [expr {$selectedline + 1}] |
| } else { |
| set l 0 |
| } |
| set ffileline $l |
| set findstartline $l |
| set diffsneeded {} |
| set fdiffsneeded {} |
| while 1 { |
| set id $lineid($l) |
| if {$findmergefiles || $nparents($id) == 1} { |
| foreach p $parents($id) { |
| if {![info exists treediffs([list $id $p])]} { |
| append diffsneeded "$id $p\n" |
| lappend fdiffsneeded [list $id $p] |
| } |
| } |
| } |
| if {[incr l] >= $numcommits} { |
| set l 0 |
| } |
| if {$l == $findstartline} break |
| } |
| |
| # start off a git-diff-tree process if needed |
| if {$diffsneeded ne {}} { |
| if {[catch { |
| set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r] |
| } err ]} { |
| error_popup "Error starting search process: $err" |
| return |
| } |
| catch {unset fdiffids} |
| set fdiffpos 0 |
| fconfigure $df -blocking 0 |
| fileevent $df readable [list readfilediffs $df] |
| } |
| |
| set finddidsel 0 |
| set findinsertpos end |
| set id $lineid($l) |
| set p [lindex $parents($id) 0] |
| . config -cursor watch |
| settextcursor watch |
| set findinprogress 1 |
| findcont [list $id $p] |
| update |
| } |
| |
| proc readfilediffs {df} { |
| global findids fdiffids fdiffs |
| |
| set n [gets $df line] |
| if {$n < 0} { |
| if {[eof $df]} { |
| donefilediff |
| if {[catch {close $df} err]} { |
| stopfindproc |
| bell |
| error_popup "Error in git-diff-tree: $err" |
| } elseif {[info exists findids]} { |
| set ids $findids |
| stopfindproc |
| bell |
| error_popup "Couldn't find diffs for {$ids}" |
| } |
| } |
| return |
| } |
| if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} { |
| # start of a new string of diffs |
| donefilediff |
| set fdiffids [list $id $p] |
| set fdiffs {} |
| } elseif {[string match ":*" $line]} { |
| lappend fdiffs [lindex $line 5] |
| } |
| } |
| |
| proc donefilediff {} { |
| global fdiffids fdiffs treediffs findids |
| global fdiffsneeded fdiffpos |
| |
| if {[info exists fdiffids]} { |
| while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids |
| && $fdiffpos < [llength $fdiffsneeded]} { |
| # git-diff-tree doesn't output anything for a commit |
| # which doesn't change anything |
| set nullids [lindex $fdiffsneeded $fdiffpos] |
| set treediffs($nullids) {} |
| if {[info exists findids] && $nullids eq $findids} { |
| unset findids |
| findcont $nullids |
| } |
| incr fdiffpos |
| } |
| incr fdiffpos |
| |
| if {![info exists treediffs($fdiffids)]} { |
| set treediffs($fdiffids) $fdiffs |
| } |
| if {[info exists findids] && $fdiffids eq $findids} { |
| unset findids |
| findcont $fdiffids |
| } |
| } |
| } |
| |
| proc findcont {ids} { |
| global findids treediffs parents nparents |
| global ffileline findstartline finddidsel |
| global lineid numcommits matchinglines findinprogress |
| global findmergefiles |
| |
| set id [lindex $ids 0] |
| set p [lindex $ids 1] |
| set pi [lsearch -exact $parents($id) $p] |
| set l $ffileline |
| while 1 { |
| if {$findmergefiles || $nparents($id) == 1} { |
| if {![info exists treediffs($ids)]} { |
| set findids $ids |
| set ffileline $l |
| return |
| } |
| set doesmatch 0 |
| foreach f $treediffs($ids) { |
| set x [findmatches $f] |
| if {$x != {}} { |
| set doesmatch 1 |
| break |
| } |
| } |
| if {$doesmatch} { |
| insertmatch $l $id |
| set pi $nparents($id) |
| } |
| } else { |
| set pi $nparents($id) |
| } |
| if {[incr pi] >= $nparents($id)} { |
| set pi 0 |
| if {[incr l] >= $numcommits} { |
| set l 0 |
| } |
| if {$l == $findstartline} break |
| set id $lineid($l) |
| } |
| set p [lindex $parents($id) $pi] |
| set ids [list $id $p] |
| } |
| stopfindproc |
| if {!$finddidsel} { |
| bell |
| } |
| } |
| |
| # mark a commit as matching by putting a yellow background |
| # behind the headline |
| proc markheadline {l id} { |
| global canv mainfont linehtag commitinfo |
| |
| set bbox [$canv bbox $linehtag($l)] |
| set t [$canv create rect $bbox -outline {} -tags matches -fill yellow] |
| $canv lower $t |
| } |
| |
| # mark the bits of a headline, author or date that match a find string |
| proc markmatches {canv l str tag matches font} { |
| set bbox [$canv bbox $tag] |
| set x0 [lindex $bbox 0] |
| set y0 [lindex $bbox 1] |
| set y1 [lindex $bbox 3] |
| foreach match $matches { |
| set start [lindex $match 0] |
| set end [lindex $match 1] |
| if {$start > $end} continue |
| set xoff [font measure $font [string range $str 0 [expr {$start-1}]]] |
| set xlen [font measure $font [string range $str 0 [expr {$end}]]] |
| set t [$canv create rect [expr {$x0+$xoff}] $y0 \ |
| [expr {$x0+$xlen+2}] $y1 \ |
| -outline {} -tags matches -fill yellow] |
| $canv lower $t |
| } |
| } |
| |
| proc unmarkmatches {} { |
| global matchinglines findids |
| allcanvs delete matches |
| catch {unset matchinglines} |
| catch {unset findids} |
| } |
| |
| proc selcanvline {w x y} { |
| global canv canvy0 ctext linespc |
| global lineid linehtag linentag linedtag rowtextx |
| set ymax [lindex [$canv cget -scrollregion] 3] |
| if {$ymax == {}} return |
| set yfrac [lindex [$canv yview] 0] |
| set y [expr {$y + $yfrac * $ymax}] |
| set l [expr {int(($y - $canvy0) / $linespc + 0.5)}] |
| if {$l < 0} { |
| set l 0 |
| } |
| if {$w eq $canv} { |
| if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return |
| } |
| unmarkmatches |
| selectline $l 1 |
| } |
| |
| proc commit_descriptor {p} { |
| global commitinfo |
| set l "..." |
| if {[info exists commitinfo($p)]} { |
| set l [lindex $commitinfo($p) 0] |
| } |
| return "$p ($l)" |
| } |
| |
| # append some text to the ctext widget, and make any SHA1 ID |
| # that we know about be a clickable link. |
| proc appendwithlinks {text} { |
| global ctext idline linknum |
| |
| set start [$ctext index "end - 1c"] |
| $ctext insert end $text |
| $ctext insert end "\n" |
| set links [regexp -indices -all -inline {[0-9a-f]{40}} $text] |
| foreach l $links { |
| set s [lindex $l 0] |
| set e [lindex $l 1] |
| set linkid [string range $text $s $e] |
| if {![info exists idline($linkid)]} continue |
| incr e |
| $ctext tag add link "$start + $s c" "$start + $e c" |
| $ctext tag add link$linknum "$start + $s c" "$start + $e c" |
| $ctext tag bind link$linknum <1> [list selectline $idline($linkid) 1] |
| incr linknum |
| } |
| $ctext tag conf link -foreground blue -underline 1 |
| $ctext tag bind link <Enter> { %W configure -cursor hand2 } |
| $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor } |
| } |
| |
| proc selectline {l isnew} { |
| global canv canv2 canv3 ctext commitinfo selectedline |
| global lineid linehtag linentag linedtag |
| global canvy0 linespc parents nparents children |
| global cflist currentid sha1entry |
| global commentend idtags idline linknum |
| |
| $canv delete hover |
| normalline |
| if {![info exists lineid($l)] || ![info exists linehtag($l)]} return |
| $canv delete secsel |
| set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \ |
| -tags secsel -fill [$canv cget -selectbackground]] |
| $canv lower $t |
| $canv2 delete secsel |
| set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \ |
| -tags secsel -fill [$canv2 cget -selectbackground]] |
| $canv2 lower $t |
| $canv3 delete secsel |
| set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \ |
| -tags secsel -fill [$canv3 cget -selectbackground]] |
| $canv3 lower $t |
| set y [expr {$canvy0 + $l * $linespc}] |
| set ymax [lindex [$canv cget -scrollregion] 3] |
| set ytop [expr {$y - $linespc - 1}] |
| set ybot [expr {$y + $linespc + 1}] |
| set wnow [$canv yview] |
| set wtop [expr {[lindex $wnow 0] * $ymax}] |
| set wbot [expr {[lindex $wnow 1] * $ymax}] |
| set wh [expr {$wbot - $wtop}] |
| set newtop $wtop |
| if {$ytop < $wtop} { |
| if {$ybot < $wtop} { |
| set newtop [expr {$y - $wh / 2.0}] |
| } else { |
| set newtop $ytop |
| if {$newtop > $wtop - $linespc} { |
| set newtop [expr {$wtop - $linespc}] |
| } |
| } |
| } elseif {$ybot > $wbot} { |
| if {$ytop > $wbot} { |
| set newtop [expr {$y - $wh / 2.0}] |
| } else { |
| set newtop [expr {$ybot - $wh}] |
| if {$newtop < $wtop + $linespc} { |
| set newtop [expr {$wtop + $linespc}] |
| } |
| } |
| } |
| if {$newtop != $wtop} { |
| if {$newtop < 0} { |
| set newtop 0 |
| } |
| allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}] |
| } |
| |
| if {$isnew} { |
| addtohistory [list selectline $l 0] |
| } |
| |
| set selectedline $l |
| |
| set id $lineid($l) |
| set currentid $id |
| $sha1entry delete 0 end |
| $sha1entry insert 0 $id |
| $sha1entry selection from 0 |
| $sha1entry selection to end |
| |
| $ctext conf -state normal |
| $ctext delete 0.0 end |
| set linknum 0 |
| $ctext mark set fmark.0 0.0 |
| $ctext mark gravity fmark.0 left |
| set info $commitinfo($id) |
| set date [formatdate [lindex $info 2]] |
| $ctext insert end "Author: [lindex $info 1] $date\n" |
| set date [formatdate [lindex $info 4]] |
| $ctext insert end "Committer: [lindex $info 3] $date\n" |
| if {[info exists idtags($id)]} { |
| $ctext insert end "Tags:" |
| foreach tag $idtags($id) { |
| $ctext insert end " $tag" |
| } |
| $ctext insert end "\n" |
| } |
| |
| set comment {} |
| if {[info exists parents($id)]} { |
| foreach p $parents($id) { |
| append comment "Parent: [commit_descriptor $p]\n" |
| } |
| } |
| if {[info exists children($id)]} { |
| foreach c $children($id) { |
| append comment "Child: [commit_descriptor $c]\n" |
| } |
| } |
| append comment "\n" |
| append comment [lindex $info 5] |
| |
| # make anything that looks like a SHA1 ID be a clickable link |
| appendwithlinks $comment |
| |
| $ctext tag delete Comments |
| $ctext tag remove found 1.0 end |
| $ctext conf -state disabled |
| set commentend [$ctext index "end - 1c"] |
| |
| $cflist delete 0 end |
| $cflist insert end "Comments" |
| if {$nparents($id) == 1} { |
| startdiff $id |
| } elseif {$nparents($id) > 1} { |
| mergediff $id |
| } |
| } |
| |
| proc selnextline {dir} { |
| global selectedline |
| if {![info exists selectedline]} return |
| set l [expr {$selectedline + $dir}] |
| unmarkmatches |
| selectline $l 1 |
| } |
| |
| proc unselectline {} { |
| global selectedline |
| |
| catch {unset selectedline} |
| allcanvs delete secsel |
| } |
| |
| proc addtohistory {cmd} { |
| global history historyindex |
| |
| if {$historyindex > 0 |
| && [lindex $history [expr {$historyindex - 1}]] == $cmd} { |
| return |
| } |
| |
| if {$historyindex < [llength $history]} { |
| set history [lreplace $history $historyindex end $cmd] |
| } else { |
| lappend history $cmd |
| } |
| incr historyindex |
| if {$historyindex > 1} { |
| .ctop.top.bar.leftbut conf -state normal |
| } else { |
| .ctop.top.bar.leftbut conf -state disabled |
| } |
| .ctop.top.bar.rightbut conf -state disabled |
| } |
| |
| proc goback {} { |
| global history historyindex |
| |
| if {$historyindex > 1} { |
| incr historyindex -1 |
| set cmd [lindex $history [expr {$historyindex - 1}]] |
| eval $cmd |
| .ctop.top.bar.rightbut conf -state normal |
| } |
| if {$historyindex <= 1} { |
| .ctop.top.bar.leftbut conf -state disabled |
| } |
| } |
| |
| proc goforw {} { |
| global history historyindex |
| |
| if {$historyindex < [llength $history]} { |
| set cmd [lindex $history $historyindex] |
| incr historyindex |
| eval $cmd |
| .ctop.top.bar.leftbut conf -state normal |
| } |
| if {$historyindex >= [llength $history]} { |
| .ctop.top.bar.rightbut conf -state disabled |
| } |
| } |
| |
| proc mergediff {id} { |
| global parents diffmergeid diffmergegca mergefilelist diffpindex |
| |
| set diffmergeid $id |
| set diffpindex -1 |
| set diffmergegca [findgca $parents($id)] |
| if {[info exists mergefilelist($id)]} { |
| if {$mergefilelist($id) ne {}} { |
| showmergediff |
| } |
| } else { |
| contmergediff {} |
| } |
| } |
| |
| proc findgca {ids} { |
| set gca {} |
| foreach id $ids { |
| if {$gca eq {}} { |
| set gca $id |
| } else { |
| if {[catch { |
| set gca [exec git-merge-base $gca $id] |
| } err]} { |
| return {} |
| } |
| } |
| } |
| return $gca |
| } |
| |
| proc contmergediff {ids} { |
| global diffmergeid diffpindex parents nparents diffmergegca |
| global treediffs mergefilelist diffids treepending |
| |
| # diff the child against each of the parents, and diff |
| # each of the parents against the GCA. |
| while 1 { |
| if {[lindex $ids 1] == $diffmergeid && $diffmergegca ne {}} { |
| set ids [list $diffmergegca [lindex $ids 0]] |
| } else { |
| if {[incr diffpindex] >= $nparents($diffmergeid)} break |
| set p [lindex $parents($diffmergeid) $diffpindex] |
| set ids [list $p $diffmergeid] |
| } |
| if {![info exists treediffs($ids)]} { |
| set diffids $ids |
| if {![info exists treepending]} { |
| gettreediffs $ids |
| } |
| return |
| } |
| } |
| |
| # If a file in some parent is different from the child and also |
| # different from the GCA, then it's interesting. |
| # If we don't have a GCA, then a file is interesting if it is |
| # different from the child in all the parents. |
| if {$diffmergegca ne {}} { |
| set files {} |
| foreach p $parents($diffmergeid) { |
| set gcadiffs $treediffs([list $diffmergegca $p]) |
| foreach f $treediffs([list $p $diffmergeid]) { |
| if {[lsearch -exact $files $f] < 0 |
| && [lsearch -exact $gcadiffs $f] >= 0} { |
| lappend files $f |
| } |
| } |
| } |
| set files [lsort $files] |
| } else { |
| set p [lindex $parents($diffmergeid) 0] |
| set files $treediffs([list $diffmergeid $p]) |
| for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} { |
| set p [lindex $parents($diffmergeid) $i] |
| set df $treediffs([list $p $diffmergeid]) |
| set nf {} |
| foreach f $files { |
| if {[lsearch -exact $df $f] >= 0} { |
| lappend nf $f |
| } |
| } |
| set files $nf |
| } |
| } |
| |
| set mergefilelist($diffmergeid) $files |
| if {$files ne {}} { |
| showmergediff |
| } |
| } |
| |
| proc showmergediff {} { |
| global cflist diffmergeid mergefilelist parents |
| global diffopts diffinhunk currentfile currenthunk filelines |
| global diffblocked groupfilelast mergefds groupfilenum grouphunks |
| |
| set files $mergefilelist($diffmergeid) |
| foreach f $files { |
| $cflist insert end $f |
| } |
| set env(GIT_DIFF_OPTS) $diffopts |
| set flist {} |
| catch {unset currentfile} |
| catch {unset currenthunk} |
| catch {unset filelines} |
| catch {unset groupfilenum} |
| catch {unset grouphunks} |
| set groupfilelast -1 |
| foreach p $parents($diffmergeid) { |
| set cmd [list | git-diff-tree -p $p $diffmergeid] |
| set cmd [concat $cmd $mergefilelist($diffmergeid)] |
| if {[catch {set f [open $cmd r]} err]} { |
| error_popup "Error getting diffs: $err" |
| foreach f $flist { |
| catch {close $f} |
| } |
| return |
| } |
| lappend flist $f |
| set ids [list $diffmergeid $p] |
| set mergefds($ids) $f |
| set diffinhunk($ids) 0 |
| set diffblocked($ids) 0 |
| fconfigure $f -blocking 0 |
| fileevent $f readable [list getmergediffline $f $ids $diffmergeid] |
| } |
| } |
| |
| proc getmergediffline {f ids id} { |
| global diffmergeid diffinhunk diffoldlines diffnewlines |
| global currentfile currenthunk |
| global diffoldstart diffnewstart diffoldlno diffnewlno |
| global diffblocked mergefilelist |
| global noldlines nnewlines difflcounts filelines |
| |
| set n [gets $f line] |
| if {$n < 0} { |
| if {![eof $f]} return |
| } |
| |
| if {!([info exists diffmergeid] && $diffmergeid == $id)} { |
| if {$n < 0} { |
| close $f |
| } |
| return |
| } |
| |
| if {$diffinhunk($ids) != 0} { |
| set fi $currentfile($ids) |
| if {$n > 0 && [regexp {^[-+ \\]} $line match]} { |
| # continuing an existing hunk |
| set line [string range $line 1 end] |
| set p [lindex $ids 1] |
| if {$match eq "-" || $match eq " "} { |
| set filelines($p,$fi,$diffoldlno($ids)) $line |
| incr diffoldlno($ids) |
| } |
| if {$match eq "+" || $match eq " "} { |
| set filelines($id,$fi,$diffnewlno($ids)) $line |
| incr diffnewlno($ids) |
| } |
| if {$match eq " "} { |
| if {$diffinhunk($ids) == 2} { |
| lappend difflcounts($ids) \ |
| [list $noldlines($ids) $nnewlines($ids)] |
| set noldlines($ids) 0 |
| set diffinhunk($ids) 1 |
| } |
| incr noldlines($ids) |
| } elseif {$match eq "-" || $match eq "+"} { |
| if {$diffinhunk($ids) == 1} { |
| lappend difflcounts($ids) [list $noldlines($ids)] |
| set noldlines($ids) 0 |
| set nnewlines($ids) 0 |
| set diffinhunk($ids) 2 |
| } |
| if {$match eq "-"} { |
| incr noldlines($ids) |
| } else { |
| incr nnewlines($ids) |
| } |
| } |
| # and if it's \ No newline at end of line, then what? |
| return |
| } |
| # end of a hunk |
| if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} { |
| lappend difflcounts($ids) [list $noldlines($ids)] |
| } elseif {$diffinhunk($ids) == 2 |
| && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} { |
| lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)] |
| } |
| set currenthunk($ids) [list $currentfile($ids) \ |
| $diffoldstart($ids) $diffnewstart($ids) \ |
| $diffoldlno($ids) $diffnewlno($ids) \ |
| $difflcounts($ids)] |
| set diffinhunk($ids) 0 |
| # -1 = need to block, 0 = unblocked, 1 = is blocked |
| set diffblocked($ids) -1 |
| processhunks |
| if {$diffblocked($ids) == -1} { |
| fileevent $f readable {} |
| set diffblocked($ids) 1 |
| } |
| } |
| |
| if {$n < 0} { |
| # eof |
| if {!$diffblocked($ids)} { |
| close $f |
| set currentfile($ids) [llength $mergefilelist($diffmergeid)] |
| set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}] |
| processhunks |
| } |
| } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} { |
| # start of a new file |
| set currentfile($ids) \ |
| [lsearch -exact $mergefilelist($diffmergeid) $fname] |
| } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \ |
| $line match f1l f1c f2l f2c rest]} { |
| if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} { |
| # start of a new hunk |
| if {$f1l == 0 && $f1c == 0} { |
| set f1l 1 |
| } |
| if {$f2l == 0 && $f2c == 0} { |
| set f2l 1 |
| } |
| set diffinhunk($ids) 1 |
| set diffoldstart($ids) $f1l |
| set diffnewstart($ids) $f2l |
| set diffoldlno($ids) $f1l |
| set diffnewlno($ids) $f2l |
| set difflcounts($ids) {} |
| set noldlines($ids) 0 |
| set nnewlines($ids) 0 |
| } |
| } |
| } |
| |
| proc processhunks {} { |
| global diffmergeid parents nparents currenthunk |
| global mergefilelist diffblocked mergefds |
| global grouphunks grouplinestart grouplineend groupfilenum |
| |
| set nfiles [llength $mergefilelist($diffmergeid)] |
| while 1 { |
| set fi $nfiles |
| set lno 0 |
| # look for the earliest hunk |
| foreach p $parents($diffmergeid) { |
| set ids [list $diffmergeid $p] |
| if {![info exists currenthunk($ids)]} return |
| set i [lindex $currenthunk($ids) 0] |
| set l [lindex $currenthunk($ids) 2] |
| if {$i < $fi || ($i == $fi && $l < $lno)} { |
| set fi $i |
| set lno $l |
| set pi $p |
| } |
| } |
| |
| if {$fi < $nfiles} { |
| set ids [list $diffmergeid $pi] |
| set hunk $currenthunk($ids) |
| unset currenthunk($ids) |
| if {$diffblocked($ids) > 0} { |
| fileevent $mergefds($ids) readable \ |
| [list getmergediffline $mergefds($ids) $ids $diffmergeid] |
| } |
| set diffblocked($ids) 0 |
| |
| if {[info exists groupfilenum] && $groupfilenum == $fi |
| && $lno <= $grouplineend} { |
| # add this hunk to the pending group |
| lappend grouphunks($pi) $hunk |
| set endln [lindex $hunk 4] |
| if {$endln > $grouplineend} { |
| set grouplineend $endln |
| } |
| continue |
| } |
| } |
| |
| # succeeding stuff doesn't belong in this group, so |
| # process the group now |
| if {[info exists groupfilenum]} { |
| processgroup |
| unset groupfilenum |
| unset grouphunks |
| } |
| |
| if {$fi >= $nfiles} break |
| |
| # start a new group |
| set groupfilenum $fi |
| set grouphunks($pi) [list $hunk] |
| set grouplinestart $lno |
| set grouplineend [lindex $hunk 4] |
| } |
| } |
| |
| proc processgroup {} { |
| global groupfilelast groupfilenum difffilestart |
| global mergefilelist diffmergeid ctext filelines |
| global parents diffmergeid diffoffset |
| global grouphunks grouplinestart grouplineend nparents |
| global mergemax |
| |
| $ctext conf -state normal |
| set id $diffmergeid |
| set f $groupfilenum |
| if {$groupfilelast != $f} { |
| $ctext insert end "\n" |
| set here [$ctext index "end - 1c"] |
| set difffilestart($f) $here |
| set mark fmark.[expr {$f + 1}] |
| $ctext mark set $mark $here |
| $ctext mark gravity $mark left |
| set header [lindex $mergefilelist($id) $f] |
| set l [expr {(78 - [string length $header]) / 2}] |
| set pad [string range "----------------------------------------" 1 $l] |
| $ctext insert end "$pad $header $pad\n" filesep |
| set groupfilelast $f |
| foreach p $parents($id) { |
| set diffoffset($p) 0 |
| } |
| } |
| |
| $ctext insert end "@@" msep |
| set nlines [expr {$grouplineend - $grouplinestart}] |
| set events {} |
| set pnum 0 |
| foreach p $parents($id) { |
| set startline [expr {$grouplinestart + $diffoffset($p)}] |
| set ol $startline |
| set nl $grouplinestart |
| if {[info exists grouphunks($p)]} { |
| foreach h $grouphunks($p) { |
| set l [lindex $h 2] |
| if {$nl < $l} { |
| for {} {$nl < $l} {incr nl} { |
| set filelines($p,$f,$ol) $filelines($id,$f,$nl) |
| incr ol |
| } |
| } |
| foreach chunk [lindex $h 5] { |
| if {[llength $chunk] == 2} { |
| set olc [lindex $chunk 0] |
| set nlc [lindex $chunk 1] |
| set nnl [expr {$nl + $nlc}] |
| lappend events [list $nl $nnl $pnum $olc $nlc] |
| incr ol $olc |
| set nl $nnl |
| } else { |
| incr ol [lindex $chunk 0] |
| incr nl [lindex $chunk 0] |
| } |
| } |
| } |
| } |
| if {$nl < $grouplineend} { |
| for {} {$nl < $grouplineend} {incr nl} { |
| set filelines($p,$f,$ol) $filelines($id,$f,$nl) |
| incr ol |
| } |
| } |
| set nlines [expr {$ol - $startline}] |
| $ctext insert end " -$startline,$nlines" msep |
| incr pnum |
| } |
| |
| set nlines [expr {$grouplineend - $grouplinestart}] |
| $ctext insert end " +$grouplinestart,$nlines @@\n" msep |
| |
| set events [lsort -integer -index 0 $events] |
| set nevents [llength $events] |
| set nmerge $nparents($diffmergeid) |
| set l $grouplinestart |
| for {set i 0} {$i < $nevents} {set i $j} { |
| set nl [lindex $events $i 0] |
| while {$l < $nl} { |
| $ctext insert end " $filelines($id,$f,$l)\n" |
| incr l |
| } |
| set e [lindex $events $i] |
| set enl [lindex $e 1] |
| set j $i |
| set active {} |
| while 1 { |
| set pnum [lindex $e 2] |
| set olc [lindex $e 3] |
| set nlc [lindex $e 4] |
| if {![info exists delta($pnum)]} { |
| set delta($pnum) [expr {$olc - $nlc}] |
| lappend active $pnum |
| } else { |
| incr delta($pnum) [expr {$olc - $nlc}] |
| } |
| if {[incr j] >= $nevents} break |
| set e [lindex $events $j] |
| if {[lindex $e 0] >= $enl} break |
| if {[lindex $e 1] > $enl} { |
| set enl [lindex $e 1] |
| } |
| } |
| set nlc [expr {$enl - $l}] |
| set ncol mresult |
| set bestpn -1 |
| if {[llength $active] == $nmerge - 1} { |
| # no diff for one of the parents, i.e. it's identical |
| for {set pnum 0} {$pnum < $nmerge} {incr pnum} { |
| if {![info exists delta($pnum)]} { |
| if {$pnum < $mergemax} { |
| lappend ncol m$pnum |
| } else { |
| lappend ncol mmax |
| } |
| break |
| } |
| } |
| } elseif {[llength $active] == $nmerge} { |
| # all parents are different, see if one is very similar |
| set bestsim 30 |
| for {set pnum 0} {$pnum < $nmerge} {incr pnum} { |
| set sim [similarity $pnum $l $nlc $f \ |
| [lrange $events $i [expr {$j-1}]]] |
| if {$sim > $bestsim} { |
| set bestsim $sim |
| set bestpn $pnum |
| } |
| } |
| if {$bestpn >= 0} { |
| lappend ncol m$bestpn |
| } |
| } |
| set pnum -1 |
| foreach p $parents($id) { |
| incr pnum |
| if {![info exists delta($pnum)] || $pnum == $bestpn} continue |
| set olc [expr {$nlc + $delta($pnum)}] |
| set ol [expr {$l + $diffoffset($p)}] |
| incr diffoffset($p) $delta($pnum) |
| unset delta($pnum) |
| for {} {$olc > 0} {incr olc -1} { |
| $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum |
| incr ol |
| } |
| } |
| set endl [expr {$l + $nlc}] |
| if {$bestpn >= 0} { |
| # show this pretty much as a normal diff |
| set p [lindex $parents($id) $bestpn] |
| set ol [expr {$l + $diffoffset($p)}] |
| incr diffoffset($p) $delta($bestpn) |
| unset delta($bestpn) |
| for {set k $i} {$k < $j} {incr k} { |
| set e [lindex $events $k] |
| if {[lindex $e 2] != $bestpn} continue |
| set nl [lindex $e 0] |
| set ol [expr {$ol + $nl - $l}] |
| for {} {$l < $nl} {incr l} { |
| $ctext insert end "+$filelines($id,$f,$l)\n" $ncol |
| } |
| set c [lindex $e 3] |
| for {} {$c > 0} {incr c -1} { |
| $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn |
| incr ol |
| } |
| set nl [lindex $e 1] |
| for {} {$l < $nl} {incr l} { |
| $ctext insert end "+$filelines($id,$f,$l)\n" mresult |
| } |
| } |
| } |
| for {} {$l < $endl} {incr l} { |
| $ctext insert end "+$filelines($id,$f,$l)\n" $ncol |
| } |
| } |
| while {$l < $grouplineend} { |
| $ctext insert end " $filelines($id,$f,$l)\n" |
| incr l |
| } |
| $ctext conf -state disabled |
| } |
| |
| proc similarity {pnum l nlc f events} { |
| global diffmergeid parents diffoffset filelines |
| |
| set id $diffmergeid |
| set p [lindex $parents($id) $pnum] |
| set ol [expr {$l + $diffoffset($p)}] |
| set endl [expr {$l + $nlc}] |
| set same 0 |
| set diff 0 |
| foreach e $events { |
| if {[lindex $e 2] != $pnum} continue |
| set nl [lindex $e 0] |
| set ol [expr {$ol + $nl - $l}] |
| for {} {$l < $nl} {incr l} { |
| incr same [string length $filelines($id,$f,$l)] |
| incr same |
| } |
| set oc [lindex $e 3] |
| for {} {$oc > 0} {incr oc -1} { |
| incr diff [string length $filelines($p,$f,$ol)] |
| incr diff |
| incr ol |
| } |
| set nl [lindex $e 1] |
| for {} {$l < $nl} {incr l} { |
| incr diff [string length $filelines($id,$f,$l)] |
| incr diff |
| } |
| } |
| for {} {$l < $endl} {incr l} { |
| incr same [string length $filelines($id,$f,$l)] |
| incr same |
| } |
| if {$same == 0} { |
| return 0 |
| } |
| return [expr {200 * $same / (2 * $same + $diff)}] |
| } |
| |
| proc startdiff {ids} { |
| global treediffs diffids treepending diffmergeid |
| |
| set diffids $ids |
| catch {unset diffmergeid} |
| if {![info exists treediffs($ids)]} { |
| if {![info exists treepending]} { |
| gettreediffs $ids |
| } |
| } else { |
| addtocflist $ids |
| } |
| } |
| |
| proc addtocflist {ids} { |
| global treediffs cflist |
| foreach f $treediffs($ids) { |
| $cflist insert end $f |
| } |
| getblobdiffs $ids |
| } |
| |
| proc gettreediffs {ids} { |
| global treediff parents treepending |
| set treepending $ids |
| set treediff {} |
| if [catch {set gdtf [open [concat | git-diff-tree --no-commit-id -r $ids] r]}] return |
| fconfigure $gdtf -blocking 0 |
| fileevent $gdtf readable [list gettreediffline $gdtf $ids] |
| } |
| |
| proc gettreediffline {gdtf ids} { |
| global treediff treediffs treepending diffids diffmergeid |
| |
| set n [gets $gdtf line] |
| if {$n < 0} { |
| if {![eof $gdtf]} return |
| close $gdtf |
| set treediffs($ids) $treediff |
| unset treepending |
| if {$ids != $diffids} { |
| gettreediffs $diffids |
| } else { |
| if {[info exists diffmergeid]} { |
| contmergediff $ids |
| } else { |
| addtocflist $ids |
| } |
| } |
| return |
| } |
| set file [lindex $line 5] |
| lappend treediff $file |
| } |
| |
| proc getblobdiffs {ids} { |
| global diffopts blobdifffd diffids env curdifftag curtagstart |
| global difffilestart nextupdate diffinhdr treediffs |
| |
| set env(GIT_DIFF_OPTS) $diffopts |
| set cmd [concat | git-diff-tree --no-commit-id -r -p -C $ids] |
| if {[catch {set bdf [open $cmd r]} err]} { |
| puts "error getting diffs: $err" |
| return |
| } |
| set diffinhdr 0 |
| fconfigure $bdf -blocking 0 |
| set blobdifffd($ids) $bdf |
| set curdifftag Comments |
| set curtagstart 0.0 |
| catch {unset difffilestart} |
| fileevent $bdf readable [list getblobdiffline $bdf $diffids] |
| set nextupdate [expr {[clock clicks -milliseconds] + 100}] |
| } |
| |
| proc getblobdiffline {bdf ids} { |
| global diffids blobdifffd ctext curdifftag curtagstart |
| global diffnexthead diffnextnote difffilestart |
| global nextupdate diffinhdr treediffs |
| |
| set n [gets $bdf line] |
| if {$n < 0} { |
| if {[eof $bdf]} { |
| close $bdf |
| if {$ids == $diffids && $bdf == $blobdifffd($ids)} { |
| $ctext tag add $curdifftag $curtagstart end |
| } |
| } |
| return |
| } |
| if {$ids != $diffids || $bdf != $blobdifffd($ids)} { |
| return |
| } |
| $ctext conf -state normal |
| if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} { |
| # start of a new file |
| $ctext insert end "\n" |
| $ctext tag add $curdifftag $curtagstart end |
| set curtagstart [$ctext index "end - 1c"] |
| set header $newname |
| set here [$ctext index "end - 1c"] |
| set i [lsearch -exact $treediffs($diffids) $fname] |
| if {$i >= 0} { |
| set difffilestart($i) $here |
| incr i |
| $ctext mark set fmark.$i $here |
| $ctext mark gravity fmark.$i left |
|
