/contrib/hgk
TCL | 4120 lines | 3712 code | 290 blank | 118 comment | 764 complexity | 0b8f67135135d436266793c0f958b7e3 MD5 | raw file
Possible License(s): GPL-2.0
Large files files are truncated, but you can click here to view the full file
- #!/usr/bin/env wish
- # 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.
- #
- # See hgk.py for extension usage and configuration.
- # Modified version of Tip 171:
- # http://www.tcl.tk/cgi-bin/tct/tip/171.html
- #
- # The in_mousewheel global was added to fix strange reentrancy issues.
- # The whole snipped is activated only under windows, mouse wheel
- # bindings working already under MacOSX and Linux.
- if {[catch {package require Ttk}]} {
- # use a shim
- namespace eval ttk {
- proc style args {}
- proc entry args {
- eval [linsert $args 0 ::entry] -relief flat
- }
- }
- interp alias {} ttk::button {} button
- interp alias {} ttk::frame {} frame
- interp alias {} ttk::label {} label
- interp alias {} ttk::scrollbar {} scrollbar
- interp alias {} ttk::optionMenu {} tk_optionMenu
- proc updatepalette {} {}
- } else {
- proc ::ttk::optionMenu {w varName firstValue args} {
- upvar #0 $varName var
- if {![info exists var]} {
- set var $firstValue
- }
- ttk::menubutton $w -textvariable $varName -menu $w.menu \
- -direction flush
- menu $w.menu -tearoff 0
- $w.menu add radiobutton -label $firstValue -variable $varName
- foreach i $args {
- $w.menu add radiobutton -label $i -variable $varName
- }
- return $w.menu
- }
- proc updatepalette {} {
- catch {
- tk_setPalette background [ttk::style lookup client -background]
- }
- }
- }
- if {[tk windowingsystem] eq "win32"} {
- ttk::style theme use xpnative
- set mw_classes [list Text Listbox Table TreeCtrl]
- foreach class $mw_classes { bind $class <MouseWheel> {} }
- set in_mousewheel 0
- proc ::tk::MouseWheel {wFired X Y D {shifted 0}} {
- global in_mousewheel
- if { $in_mousewheel != 0 } { return }
- # Set event to check based on call
- set evt "<[expr {$shifted?{Shift-}:{}}]MouseWheel>"
- # do not double-fire in case the class already has a binding
- if {[bind [winfo class $wFired] $evt] ne ""} { return }
- # obtain the window the mouse is over
- set w [winfo containing $X $Y]
- # if we are outside the app, try and scroll the focus widget
- if {![winfo exists $w]} { catch {set w [focus]} }
- if {[winfo exists $w]} {
- if {[bind $w $evt] ne ""} {
- # Awkward ... this widget has a MouseWheel binding, but to
- # trigger successfully in it, we must give it focus.
- catch {focus} old
- if {$w ne $old} { focus $w }
- set in_mousewheel 1
- event generate $w $evt -rootx $X -rooty $Y -delta $D
- set in_mousewheel 0
- if {$w ne $old} { focus $old }
- return
- }
- # aqua and x11/win32 have different delta handling
- if {[tk windowingsystem] ne "aqua"} {
- set delta [expr {- ($D / 30)}]
- } else {
- set delta [expr {- ($D)}]
- }
- # scrollbars have different call conventions
- if {[string match "*Scrollbar" [winfo class $w]]} {
- catch {tk::ScrollByUnits $w \
- [string index [$w cget -orient] 0] $delta}
- } else {
- set cmd [list $w [expr {$shifted ? "xview" : "yview"}] \
- scroll $delta units]
- # Walking up to find the proper widget (handles cases like
- # embedded widgets in a canvas)
- while {[catch $cmd] && [winfo toplevel $w] ne $w} {
- set w [winfo parent $w]
- }
- }
- }
- }
- bind all <MouseWheel> [list ::tk::MouseWheel %W %X %Y %D 0]
- # end of win32 section
- } else {
- if {[catch {
- set theme [ttk::style theme use]
- }]} {
- set theme $::ttk::currentTheme
- }
- if {$theme eq "default"} {
- ttk::style theme use clam
- }
- }
- updatepalette
- # Unify right mouse button handling.
- # See "mouse buttons on macintosh" thread on comp.lang.tcl
- if {[tk windowingsystem] eq "aqua"} {
- event add <<B3>> <Control-ButtonPress-1>
- event add <<B3>> <Button-2>
- } else {
- event add <<B3>> <Button-3>
- }
- proc gitdir {} {
- global env
- if {[info exists env(GIT_DIR)]} {
- return $env(GIT_DIR)
- } else {
- return ".hg"
- }
- }
- proc popupify {w} {
- wm resizable $w 0 0
- wm withdraw $w
- update
- set x [expr {([winfo screenwidth .]-[winfo reqwidth $w])/2}]
- set y [expr {([winfo screenheight .]-[winfo reqheight $w])/2}]
- wm geometry $w +$x+$y
- wm transient $w .
- wm deiconify $w
- wm resizable $w 1 1
- }
- proc getcommits {rargs} {
- global commits commfd phase canv mainfont env
- global startmsecs nextupdate ncmupdate
- global ctext maincursor textcursor leftover
- # 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 commits {}
- set phase getcommits
- set startmsecs [clock clicks -milliseconds]
- set nextupdate [expr $startmsecs + 100]
- set ncmupdate 1
- set limit 0
- set revargs {}
- for {set i 0} {$i < [llength $rargs]} {incr i} {
- set opt [lindex $rargs $i]
- if {$opt == "--limit"} {
- incr i
- set limit [lindex $rargs $i]
- } else {
- lappend revargs $opt
- }
- }
- if [catch {
- set parse_args [concat --default HEAD $revargs]
- set parse_temp [eval exec {$env(HG)} --config ui.report_untrusted=false debug-rev-parse $parse_args]
- regsub -all "\r\n" $parse_temp "\n" parse_temp
- set parsed_args [split $parse_temp "\n"]
- } err] {
- # if git-rev-parse failed for some reason...
- if {$rargs == {}} {
- set revargs HEAD
- }
- set parsed_args $revargs
- }
- if {$limit > 0} {
- set parsed_args [concat -n $limit $parsed_args]
- }
- if [catch {
- set commfd [open "|{$env(HG)} --config ui.report_untrusted=false debug-rev-list --header --topo-order --parents $parsed_args" r]
- } err] {
- puts stderr "Error executing hg debug-rev-list: $err"
- exit 1
- }
- set leftover {}
- fconfigure $commfd -blocking 0 -translation lf -eofchar {}
- fileevent $commfd readable [list getcommitlines $commfd]
- $canv delete all
- $canv create text 3 3 -anchor nw -text "Reading commits..." \
- -font $mainfont -tags textitems
- . config -cursor watch
- settextcursor watch
- }
- proc getcommitlines {commfd} {
- global commits parents cdate children
- global commitlisted phase commitinfo nextupdate
- global stopped redisplaying leftover
- 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}]
- regsub -all "\r\n" $cmit "\n" cmit
- 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]{12}$} $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 hg debug-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
- 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
- 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} {
- global env
- if [catch {set contents [exec $env(HG) --config ui.report_untrusted=false debug-cat-file commit $id]}] return
- parsecommit $id $contents 0 {}
- }
- proc parsecommit {id contents listed olds} {
- global commitinfo children nchildren parents nparents cdate ncleft
- global firstparents
- set inhdr 1
- set comment {}
- set headline {}
- set auname {}
- set audate {}
- set comname {}
- set comdate {}
- set rev {}
- set branch {}
- set bookmark {}
- 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)
- }
- }
- regsub -all "\r\n" $contents "\n" contents
- foreach line [split $contents "\n"] {
- if {$inhdr} {
- set line [split $line]
- if {$line == {}} {
- set inhdr 0
- } else {
- set tag [lindex $line 0]
- if {$tag == "author"} {
- set x [expr {[llength $line] - 2}]
- set audate [lindex $line $x]
- set auname [join [lrange $line 1 [expr {$x - 1}]]]
- } elseif {$tag == "committer"} {
- set x [expr {[llength $line] - 2}]
- set comdate [lindex $line $x]
- set comname [join [lrange $line 1 [expr {$x - 1}]]]
- } elseif {$tag == "revision"} {
- set rev [lindex $line 1]
- } elseif {$tag == "branch"} {
- set branch [join [lrange $line 1 end]]
- } elseif {$tag == "bookmark"} {
- set bookmark [join [lrange $line 1 end]]
- }
- }
- } else {
- if {$comment == {}} {
- set headline [string trim $line]
- } else {
- append comment "\n"
- }
- if {!$listed} {
- # git-rev-list indents the comment by 4 spaces;
- # if we got this via git-cat-file, add the indentation
- append comment " "
- }
- append comment $line
- }
- }
- if {$audate != {}} {
- set audate [clock format $audate]
- }
- if {$comdate != {}} {
- set cdate($id) $comdate
- set comdate [clock format $comdate]
- }
- set commitinfo($id) [list $headline $auname $audate \
- $comname $comdate $comment $rev $branch $bookmark]
- if {[info exists firstparents]} {
- set i [lsearch $firstparents $id]
- if {$i != -1} {
- # remove the parent from firstparents, possible building
- # an empty list
- set firstparents [concat \
- [lrange $firstparents 0 [expr $i - 1]] \
- [lrange $firstparents [expr $i + 1] end]]
- if {$firstparents eq {}} {
- # we have found all parents of the first changeset
- # which means that we can safely select the first line
- after idle {
- selectline 0 0
- }
- }
- }
- } else {
- # this is the first changeset, save the parents
- set firstparents $olds
- if {$firstparents eq {}} {
- # a repository with a single changeset
- after idle {
- selectline 0 0
- }
- }
- }
- }
- proc readrefs {} {
- global bookmarkcurrent bookmarkids tagids idtags idbookmarks headids idheads tagcontents env curid
- set status [catch {exec $env(HG) --config ui.report_untrusted=false id} curid]
- if { $status != 0 } {
- puts $::errorInfo
- if { ![string equal $::errorCode NONE] } {
- exit 2
- }
- }
- regexp -- {[[:xdigit:]]+} $curid curid
- set status [catch {exec $env(HG) --config ui.report_untrusted=false tags} tags]
- if { $status != 0 } {
- puts $::errorInfo
- if { ![string equal $::errorCode NONE] } {
- exit 2
- }
- }
- foreach {- tag rev id} [regexp -inline -all -line {^(.+\S)\s+(\d+):(\S+)} $tags] {
- # we use foreach as Tcl8.4 doesn't support lassign
- lappend tagids($tag) $id
- lappend idtags($id) $tag
- }
- set status [catch {exec $env(HG) --config ui.report_untrusted=false heads} heads]
- if { $status != 0 } {
- puts $::errorInfo
- if { ![string equal $::errorCode NONE] } {
- exit 2
- }
- }
- set lines [split $heads \r\n]
- foreach f $lines {
- set match ""
- regexp {changeset:\s+(\S+):(\S+)$} $f match id sha
- if {$match != ""} {
- lappend idheads($sha) $id
- }
- }
- set status [catch {exec $env(HG) --config ui.report_untrusted=false bookmarks} bookmarks]
- if { $status != 0 } {
- puts $::errorInfo
- if { ![string equal $::errorCode NONE] } {
- exit 2
- }
- }
- set lines [split $bookmarks "\n"]
- set bookmarkcurrent 0
- foreach f $lines {
- regexp {(\S+)$} $f full
- regsub {\s+(\S+)$} $f "" direct
- set sha [split $full ':']
- set bookmark [lindex $sha 1]
- set current [string first " * " $direct)]
- regsub {^\s(\*|\s)\s} $direct "" direct
- lappend bookmarkids($direct) $bookmark
- lappend idbookmarks($bookmark) $direct
- if {$current >= 0} {
- set bookmarkcurrent $direct
- }
- }
- }
- proc readotherrefs {base dname excl} {
- global otherrefids idotherrefs
- set git [gitdir]
- set files [glob -nocomplain -types f [file join $git $base *]]
- foreach f $files {
- catch {
- set fd [open $f r]
- set line [read $fd 40]
- if {[regexp {^[0-9a-f]{12}} $line id]} {
- set name "$dname[file tail $f]"
- set otherrefids($name) $id
- lappend idotherrefs($id) $name
- }
- close $fd
- }
- }
- set dirs [glob -nocomplain -types d [file join $git $base *]]
- foreach d $dirs {
- set dir [file tail $d]
- if {[lsearch -exact $excl $dir] >= 0} continue
- readotherrefs [file join $base $dir] "$dname$dir/" {}
- }
- }
- proc allcansmousewheel {delta} {
- set delta [expr -5*(int($delta)/abs($delta))]
- allcanvs yview scroll $delta units
- }
- 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
- ttk::button $w.ok -text OK -command "destroy $w"
- pack $w.ok -side bottom -fill x
- bind $w <Visibility> "grab $w; focus $w"
- popupify $w
- tkwait window $w
- }
- proc makewindow {} {
- 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 gaudydiff mergemax
- global hgvdiff bgcolor fgcolor diffremcolor diffaddcolor diffmerge1color
- global diffmerge2color hunksepcolor
- global posx posy
- if {[info exists posx]} {
- wm geometry . +$posx+$posy
- }
- menu .bar
- .bar add cascade -label "File" -menu .bar.file
- menu .bar.file
- .bar.file add command -label "Reread references" -command rereadrefs
- .bar.file add command -label "Quit" -command doquit
- menu .bar.help
- .bar add cascade -label "Help" -menu .bar.help
- .bar.help add command -label "About hgk" -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]}]
- }
- ttk::frame .ctop.top
- ttk::frame .ctop.top.bar
- pack .ctop.top.bar -side bottom -fill x
- set cscroll .ctop.top.csb
- ttk::scrollbar $cscroll -command {allcanvs yview}
- 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 $bgcolor -bd 0 \
- -yscrollincr $linespc -yscrollcommand "$cscroll set" -selectbackground "#c0c0c0"
- .ctop.top.clist add $canv
- set canv2 .ctop.top.clist.canv2
- canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
- -bg $bgcolor -bd 0 -yscrollincr $linespc -selectbackground "#c0c0c0"
- .ctop.top.clist add $canv2
- set canv3 .ctop.top.clist.canv3
- canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
- -bg $bgcolor -bd 0 -yscrollincr $linespc -selectbackground "#c0c0c0"
- .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
- ttk::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};
- }
- ttk::button .ctop.top.bar.leftbut -image bm-left -command goback \
- -state disabled -width 26
- pack .ctop.top.bar.leftbut -side left -fill y
- ttk::button .ctop.top.bar.rightbut -image bm-right -command goforw \
- -state disabled -width 26
- pack .ctop.top.bar.rightbut -side left -fill y
- ttk::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
- ttk::entry $fstring -width 30 -font $textfont -textvariable findstring
- pack $fstring -side left -expand 1 -fill x
- set findtype Exact
- set findtypemenu [ttk::optionMenu .ctop.top.bar.findtype \
- findtype Exact IgnCase Regexp]
- set findloc "All fields"
- ttk::optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
- Comments Author 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
- ttk::frame .ctop.cdet.left
- set ctext .ctop.cdet.left.ctext
- text $ctext -fg $fgcolor -bg $bgcolor -state disabled -font $textfont \
- -width $geometry(ctextw) -height $geometry(ctexth) \
- -yscrollcommand ".ctop.cdet.left.sb set" \
- -xscrollcommand ".ctop.cdet.left.hb set" -wrap none
- ttk::scrollbar .ctop.cdet.left.sb -command "$ctext yview"
- ttk::scrollbar .ctop.cdet.left.hb -orient horizontal -command "$ctext xview"
- pack .ctop.cdet.left.sb -side right -fill y
- pack .ctop.cdet.left.hb -side bottom -fill x
- pack $ctext -side left -fill both -expand 1
- .ctop.cdet add .ctop.cdet.left
- $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
- if {$gaudydiff} {
- $ctext tag conf hunksep -back blue -fore white
- $ctext tag conf d0 -back "#ff8080"
- $ctext tag conf d1 -back green
- } else {
- $ctext tag conf hunksep -fore $hunksepcolor
- $ctext tag conf d0 -fore $diffremcolor
- $ctext tag conf d1 -fore $diffaddcolor
- # The mX colours seem to be used in merge changesets, where m0
- # is first parent, m1 is second parent and so on. Git can have
- # several parents, Hg cannot, so I think the m2..mmax would be
- # unused.
- $ctext tag conf m0 -fore $diffmerge1color
- $ctext tag conf m1 -fore $diffmerge2color
- $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
- }
- ttk::frame .ctop.cdet.right
- set cflist .ctop.cdet.right.cfiles
- listbox $cflist -fg $fgcolor -bg $bgcolor \
- -selectmode extended -width $geometry(cflistw) \
- -yscrollcommand ".ctop.cdet.right.sb set"
- ttk::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 <MouseWheel> "allcansmousewheel %D"
- 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-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 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-w> 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
- if { $hgvdiff ne "" } {
- $rowctxmenu add command -label "Visual diff with parent" \
- -command {vdiff 1}
- $rowctxmenu add command -label "Visual diff with selected" \
- -command {vdiff 0}
- }
- }
- # 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 .
- }
- proc savestuff {w} {
- global canv canv2 canv3 ctext cflist mainfont textfont
- global stuffsaved findmergefiles gaudydiff maxgraphpct
- global maxwidth authorcolors curidfont bgcolor fgcolor
- global diffremcolor diffaddcolor hunksepcolor
- global diffmerge1color diffmerge2color
- if {$stuffsaved} return
- if {![winfo viewable .]} return
- catch {
- set f [open "~/.hgk-new" w]
- puts $f [list set mainfont $mainfont]
- puts $f [list set curidfont $curidfont]
- puts $f [list set textfont $textfont]
- puts $f [list set findmergefiles $findmergefiles]
- puts $f [list set gaudydiff $gaudydiff]
- 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"
- puts $f "#"
- puts $f "# main window position:"
- puts $f "set posx [winfo x .]"
- puts $f "set posy [winfo y .]"
- puts $f "#"
- puts $f "# authorcolors format:"
- puts $f "#"
- puts $f "# zero or more sublists of"
- puts $f "#"
- puts $f "# { regex color }"
- puts $f "#"
- puts $f "# followed by a list of colors"
- puts $f "#"
- puts $f "# If the commit author matches a regex in a sublist,"
- puts $f "# the commit will be colored by that color"
- puts $f "# otherwise the next unused entry from the list of colors"
- puts $f "# will be assigned to this commit and also all other commits"
- puts $f "# of the same author. When the list of colors is exhausted,"
- puts $f "# the last entry will be reused."
- puts $f "#"
- puts $f "set authorcolors {$authorcolors}"
- puts $f "#"
- puts $f "# The background color in the text windows"
- puts $f "set bgcolor $bgcolor"
- puts $f "#"
- puts $f "# The text color used in the diff and file list view"
- puts $f "set fgcolor $fgcolor"
- puts $f "#"
- puts $f "# Color to display + lines in diffs"
- puts $f "set diffaddcolor $diffaddcolor"
- puts $f "#"
- puts $f "# Color to display - lines in diffs"
- puts $f "set diffremcolor $diffremcolor"
- puts $f "#"
- puts $f "# Merge diffs: Color to signal lines from first parent"
- puts $f "set diffmerge1color $diffmerge1color"
- puts $f "#"
- puts $f "# Merge diffs: Color to signal lines from second parent"
- puts $f "set diffmerge2color $diffmerge2color"
- puts $f "#"
- puts $f "# Hunkseparator (@@ -lineno,lines +lineno,lines @@) color"
- puts $f "set hunksepcolor $hunksepcolor"
- close $f
- file rename -force "~/.hgk-new" "~/.hgk"
- }
- 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 hgk"
- message $w.m -text {
- Hgk 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
- ttk::button $w.ok -text Close -command "destroy $w"
- pack $w.ok -side bottom
- popupify $w
- }
- set aunextcolor 0
- proc assignauthorcolor {name} {
- global authorcolors aucolormap aunextcolor
- if [info exists aucolormap($name)] return
- set randomcolors {black}
- for {set i 0} {$i < [llength $authorcolors]} {incr i} {
- set col [lindex $authorcolors $i]
- if {[llength $col] > 1} {
- set re [lindex $col 0]
- set c [lindex $col 1]
- if {[regexp -- $re $name]} {
- set aucolormap($name) $c
- return
- }
- } else {
- set randomcolors [lrange $authorcolors $i end]
- break
- }
- }
- set ncolors [llength $randomcolors]
- set c [lindex $randomcolors $aunextcolor]
- if {[incr aunextcolor] >= $ncolors} {
- incr aunextcolor -1
- }
- set aucolormap($name) $c
- }
- proc assigncolor {id} {
- global commitinfo 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 mainline mainlinearrow sidelines
- global nchildren ncleft
- global displist nhyperspace
- allcanvs delete all
- set nextcolor 0
- set canvy $canvy0
- set lineno -1
- set numcommits 0
- catch {unset mainline}
- catch {unset mainlinearrow}
- catch {unset sidelines}
- 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} {
- global mainline mainlinearrow sidelines lthickness colormap canv
- $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 idbookmarks
- global lineno lthickness mainline mainlinearrow sidelines
- global commitlisted rowtextx idpos lastuse displist
- global oldnlines olddlevel olddisplist
- global aucolormap curid curidfont
- 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
- 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)] || [info exists idbookmarks($id)]} {
- set xt [drawtags $id $x $xt $y1]
- }
- set headline [lindex $commitinfo($id) 0]
- set name [lindex $commitinfo($id) 1]
- assignauthorcolor $name
- set fg $aucolormap($name)
- if {$id == $curid} {
- set fn $curidfont
- } else {
- set fn $mainfont
- }
- set date [lindex $commitinfo($id) 2]
- set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
- -text $headline -font $fn \
- -fill $fg]
- $canv bind $linehtag($lineno) <<B3>> "rowmenu %X %Y $id"
- set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
- -text $name -font $namefont \
- -fill $fg]
- set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
- -text $date -font $mainfont \
- -fill $fg]
- set olddlevel $level
- set olddisplist $displist
- set oldnlines [llength $displist]
- }
- proc drawtags {id x xt y1} {
- global bookmarkcurrent idtags idbookmarks idheads idotherrefs commitinfo
- global linespc lthickness
- global canv mainfont idline rowtextx
- set marks {}
- set nbookmarks 0
- set ntags 0
- set nheads 0
- if {[info exists idtags($id)]} {
- set marks $idtags($id)
- set ntags [llength $marks]
- }
- if {[info exists idbookmarks($id)]} {
- set marks [concat $marks $idbookmarks($id)]
- set nbookmarks [llength $idbookmarks($id)]
- }
- if {[info exists idheads($id)]} {
- set headmark [lindex $commitinfo($id) 7]
- if {$headmark ne "default"} {
- lappend marks $headmark
- set nheads 1
- }
- }
- 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}]
- } elseif {[incr nbookmarks -1] >= 0} {
- # draw a tag
- set col gray50
- if {[string compare $bookmarkcurrent $tag] == 0} {
- set col gray
- }
- 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
- } else {
- # draw a head or other ref
- if {[incr nheads -1] >= 0} {
- set col "#00ff00"
- } 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 …
Large files files are truncated, but you can click here to view the full file