freshlybakedca.ke
Git fork
1#!/bin/sh
2# Tcl ignores the next line -*- tcl -*- \
3exec wish "$0" -- "$@"
4
5# Copyright © 2005-2016 Paul Mackerras. All rights reserved.
6# This program is free software; it may be used, copied, modified
7# and distributed under the terms of the GNU General Public Licence,
8# either version 2, or (at your option) any later version.
9
10if {[catch {package require Tcl 8.6-} err]} {
11 catch {wm withdraw .}
12 tk_messageBox \
13 -icon error \
14 -type ok \
15 -title "gitk: fatal error" \
16 -message $err
17 exit 1
18}
19
20set MIN_GIT_VERSION 2.20
21regexp {^git version ([\d.]*\d)} [exec git version] _ git_version
22if {[package vcompare $git_version $MIN_GIT_VERSION] < 0} {
23 set message "The git executable found is too old.
24The minimum required version is $MIN_GIT_VERSION.0.
25The version of git found is $git_version."
26
27 catch {wm withdraw .}
28 tk_messageBox \
29 -icon error \
30 -type ok \
31 -title "gitk: fatal error" \
32 -message $message
33 exit 1
34}
35
36######################################################################
37## Enable Tcl8 profile in Tcl9, allowing consumption of data that has
38## bytes not conforming to the assumed encoding profile.
39
40if {[package vcompare $::tcl_version 9.0] >= 0} {
41 rename open _strict_open
42 proc open args {
43 set f [_strict_open {*}$args]
44 chan configure $f -profile tcl8
45 return $f
46 }
47 proc convertfrom args {
48 return [encoding convertfrom -profile tcl8 {*}$args]
49 }
50} else {
51 proc convertfrom args {
52 return [encoding convertfrom {*}$args]
53 }
54}
55
56######################################################################
57##
58## Enabling platform-specific code paths
59
60proc is_Windows {} {
61 if {$::tcl_platform(platform) eq {windows}} {
62 return 1
63 }
64 return 0
65}
66
67######################################################################
68##
69## PATH lookup
70
71if {[is_Windows]} {
72 set _search_path {}
73 proc _which {what args} {
74 global env _search_path
75
76 if {$_search_path eq {}} {
77 set gitguidir [file dirname [info script]]
78 regsub -all ";" $gitguidir "\\;" gitguidir
79 set env(PATH) "$gitguidir;$env(PATH)"
80 set _search_path [split $env(PATH) {;}]
81 # Skip empty `PATH` elements
82 set _search_path [lsearch -all -inline -not -exact \
83 $_search_path ""]
84 }
85
86 if {[lsearch -exact $args -script] >= 0} {
87 set suffix {}
88 } else {
89 set suffix .exe
90 }
91
92 foreach p $_search_path {
93 set p [file join $p $what$suffix]
94 if {[file exists $p]} {
95 return [file normalize $p]
96 }
97 }
98 return {}
99 }
100
101 proc sanitize_command_line {command_line from_index} {
102 set i $from_index
103 while {$i < [llength $command_line]} {
104 set cmd [lindex $command_line $i]
105 if {[llength [file split $cmd]] < 2} {
106 set fullpath [_which $cmd]
107 if {$fullpath eq ""} {
108 throw {NOT-FOUND} "$cmd not found in PATH"
109 }
110 lset command_line $i $fullpath
111 }
112
113 # handle piped commands, e.g. `exec A | B`
114 for {incr i} {$i < [llength $command_line]} {incr i} {
115 if {[lindex $command_line $i] eq "|"} {
116 incr i
117 break
118 }
119 }
120 }
121 return $command_line
122 }
123
124 # Override `exec` to avoid unsafe PATH lookup
125
126 rename exec real_exec
127
128 proc exec {args} {
129 # skip options
130 for {set i 0} {$i < [llength $args]} {incr i} {
131 set arg [lindex $args $i]
132 if {$arg eq "--"} {
133 incr i
134 break
135 }
136 if {[string range $arg 0 0] ne "-"} {
137 break
138 }
139 }
140 set args [sanitize_command_line $args $i]
141 uplevel 1 real_exec $args
142 }
143
144 # Override `open` to avoid unsafe PATH lookup
145
146 rename open real_open
147
148 proc open {args} {
149 set arg0 [lindex $args 0]
150 if {[string range $arg0 0 0] eq "|"} {
151 set command_line [string trim [string range $arg0 1 end]]
152 lset args 0 "| [sanitize_command_line $command_line 0]"
153 }
154 uplevel 1 real_open $args
155 }
156}
157
158# End of safe PATH lookup stuff
159
160# Wrap exec/open to sanitize arguments
161
162# unsafe arguments begin with redirections or the pipe or background operators
163proc is_arg_unsafe {arg} {
164 regexp {^([<|>&]|2>)} $arg
165}
166
167proc make_arg_safe {arg} {
168 if {[is_arg_unsafe $arg]} {
169 set arg [file join . $arg]
170 }
171 return $arg
172}
173
174proc make_arglist_safe {arglist} {
175 set res {}
176 foreach arg $arglist {
177 lappend res [make_arg_safe $arg]
178 }
179 return $res
180}
181
182# executes one command
183# no redirections or pipelines are possible
184# cmd is a list that specifies the command and its arguments
185# calls `exec` and returns its value
186proc safe_exec {cmd} {
187 eval exec [make_arglist_safe $cmd]
188}
189
190# executes one command with redirections
191# no pipelines are possible
192# cmd is a list that specifies the command and its arguments
193# redir is a list that specifies redirections (output, background, constant(!) commands)
194# calls `exec` and returns its value
195proc safe_exec_redirect {cmd redir} {
196 eval exec [make_arglist_safe $cmd] $redir
197}
198
199proc safe_open_file {filename flags} {
200 # a file name starting with "|" would attempt to run a process
201 # but such a file name must be treated as a relative path
202 # hide the "|" behind "./"
203 if {[string index $filename 0] eq "|"} {
204 set filename [file join . $filename]
205 }
206 open $filename $flags
207}
208
209# opens a command pipeline for reading
210# cmd is a list that specifies the command and its arguments
211# calls `open` and returns the file id
212proc safe_open_command {cmd} {
213 open |[make_arglist_safe $cmd] r
214}
215
216# opens a command pipeline for reading and writing
217# cmd is a list that specifies the command and its arguments
218# calls `open` and returns the file id
219proc safe_open_command_rw {cmd} {
220 open |[make_arglist_safe $cmd] r+
221}
222
223# opens a command pipeline for reading with redirections
224# cmd is a list that specifies the command and its arguments
225# redir is a list that specifies redirections
226# calls `open` and returns the file id
227proc safe_open_command_redirect {cmd redir} {
228 set cmd [make_arglist_safe $cmd]
229 open |[concat $cmd $redir] r
230}
231
232# opens a pipeline with several commands for reading
233# cmds is a list of lists, each of which specifies a command and its arguments
234# calls `open` and returns the file id
235proc safe_open_pipeline {cmds} {
236 set cmd {}
237 foreach subcmd $cmds {
238 set cmd [concat $cmd | [make_arglist_safe $subcmd]]
239 }
240 open $cmd r
241}
242
243# End exec/open wrappers
244
245proc hasworktree {} {
246 return [expr {[exec git rev-parse --is-bare-repository] == "false" &&
247 [exec git rev-parse --is-inside-git-dir] == "false"}]
248}
249
250proc reponame {} {
251 global gitdir
252 set n [file normalize $gitdir]
253 if {[string match "*/.git" $n]} {
254 set n [string range $n 0 end-5]
255 }
256 return [file tail $n]
257}
258
259proc gitworktree {} {
260 variable _gitworktree
261 if {[info exists _gitworktree]} {
262 return $_gitworktree
263 }
264 # v1.7.0 introduced --show-toplevel to return the canonical work-tree
265 if {[catch {set _gitworktree [exec git rev-parse --show-toplevel]}]} {
266 # try to set work tree from environment, core.worktree or use
267 # cdup to obtain a relative path to the top of the worktree. If
268 # run from the top, the ./ prefix ensures normalize expands pwd.
269 if {[catch { set _gitworktree $env(GIT_WORK_TREE) }]} {
270 if {[catch {set _gitworktree [exec git config --get core.worktree]}]} {
271 set _gitworktree [file normalize ./[exec git rev-parse --show-cdup]]
272 }
273 }
274 }
275 return $_gitworktree
276}
277
278# A simple scheduler for compute-intensive stuff.
279# The aim is to make sure that event handlers for GUI actions can
280# run at least every 50-100 ms. Unfortunately fileevent handlers are
281# run before X event handlers, so reading from a fast source can
282# make the GUI completely unresponsive.
283proc run args {
284 global isonrunq runq currunq
285
286 set script $args
287 if {[info exists isonrunq($script)]} return
288 if {$runq eq {} && ![info exists currunq]} {
289 after idle dorunq
290 }
291 lappend runq [list {} $script]
292 set isonrunq($script) 1
293}
294
295proc filerun {fd script} {
296 fileevent $fd readable [list filereadable $fd $script]
297}
298
299proc filereadable {fd script} {
300 global runq currunq
301
302 fileevent $fd readable {}
303 if {$runq eq {} && ![info exists currunq]} {
304 after idle dorunq
305 }
306 lappend runq [list $fd $script]
307}
308
309proc nukefile {fd} {
310 global runq
311
312 for {set i 0} {$i < [llength $runq]} {} {
313 if {[lindex $runq $i 0] eq $fd} {
314 set runq [lreplace $runq $i $i]
315 } else {
316 incr i
317 }
318 }
319}
320
321proc dorunq {} {
322 global isonrunq runq currunq
323
324 set tstart [clock clicks -milliseconds]
325 set t0 $tstart
326 while {[llength $runq] > 0} {
327 set fd [lindex $runq 0 0]
328 set script [lindex $runq 0 1]
329 set currunq [lindex $runq 0]
330 set runq [lrange $runq 1 end]
331 set repeat [eval $script]
332 unset currunq
333 set t1 [clock clicks -milliseconds]
334 set t [expr {$t1 - $t0}]
335 if {$repeat ne {} && $repeat} {
336 if {$fd eq {} || $repeat == 2} {
337 # script returns 1 if it wants to be readded
338 # file readers return 2 if they could do more straight away
339 lappend runq [list $fd $script]
340 } else {
341 fileevent $fd readable [list filereadable $fd $script]
342 }
343 } elseif {$fd eq {}} {
344 unset isonrunq($script)
345 }
346 set t0 $t1
347 if {$t1 - $tstart >= 80} break
348 }
349 if {$runq ne {}} {
350 after idle dorunq
351 }
352}
353
354proc reg_instance {fd} {
355 global commfd leftover loginstance
356
357 set i [incr loginstance]
358 set commfd($i) $fd
359 set leftover($i) {}
360 return $i
361}
362
363proc unmerged_files {files} {
364 global nr_unmerged
365
366 # find the list of unmerged files
367 set mlist {}
368 set nr_unmerged 0
369 if {[catch {
370 set fd [safe_open_command {git ls-files -u}]
371 } err]} {
372 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
373 exit 1
374 }
375 while {[gets $fd line] >= 0} {
376 set i [string first "\t" $line]
377 if {$i < 0} continue
378 set fname [string range $line [expr {$i+1}] end]
379 if {[lsearch -exact $mlist $fname] >= 0} continue
380 incr nr_unmerged
381 if {$files eq {} || [path_filter $files $fname]} {
382 lappend mlist $fname
383 }
384 }
385 catch {close $fd}
386 return $mlist
387}
388
389proc parseviewargs {n arglist} {
390 global vdatemode vmergeonly vflags vdflags vrevs vfiltered vorigargs env
391 global vinlinediff
392 global worddiff
393
394 set vdatemode($n) 0
395 set vmergeonly($n) 0
396 set vinlinediff($n) 0
397 set glflags {}
398 set diffargs {}
399 set nextisval 0
400 set revargs {}
401 set origargs $arglist
402 set allknown 1
403 set filtered 0
404 set i -1
405 foreach arg $arglist {
406 incr i
407 if {$nextisval} {
408 lappend glflags $arg
409 set nextisval 0
410 continue
411 }
412 switch -glob -- $arg {
413 "-d" -
414 "--date-order" {
415 set vdatemode($n) 1
416 # remove from origargs in case we hit an unknown option
417 set origargs [lreplace $origargs $i $i]
418 incr i -1
419 }
420 "-[puabwcrRBMC]" -
421 "--no-renames" - "--full-index" - "--binary" - "--abbrev=*" -
422 "--find-copies-harder" - "-l*" - "--ext-diff" - "--no-ext-diff" -
423 "--src-prefix=*" - "--dst-prefix=*" - "--no-prefix" -
424 "-O*" - "--text" - "--full-diff" - "--ignore-space-at-eol" -
425 "--ignore-space-change" - "-U*" - "--unified=*" {
426 # These request or affect diff output, which we don't want.
427 # Some could be used to set our defaults for diff display.
428 lappend diffargs $arg
429 }
430 "--raw" - "--patch-with-raw" - "--patch-with-stat" -
431 "--name-only" - "--name-status" - "--color" -
432 "--log-size" - "--pretty=*" - "--decorate" - "--abbrev-commit" -
433 "--cc" - "-z" - "--header" - "--parents" - "--boundary" -
434 "--no-color" - "-g" - "--walk-reflogs" - "--no-walk" -
435 "--timestamp" - "relative-date" - "--date=*" - "--stdin" -
436 "--objects" - "--objects-edge" - "--reverse" {
437 # These cause our parsing of git log's output to fail, or else
438 # they're options we want to set ourselves, so ignore them.
439 }
440 "--color-words*" - "--word-diff=color" {
441 # These trigger a word diff in the console interface,
442 # so help the user by enabling our own support
443 set worddiff [mc "Color words"]
444 }
445 "--word-diff*" {
446 set worddiff [mc "Markup words"]
447 }
448 "--stat=*" - "--numstat" - "--shortstat" - "--summary" -
449 "--check" - "--exit-code" - "--quiet" - "--topo-order" -
450 "--full-history" - "--dense" - "--sparse" -
451 "--follow" - "--left-right" - "--encoding=*" {
452 # These are harmless, and some are even useful
453 lappend glflags $arg
454 }
455 "--diff-filter=*" - "--no-merges" - "--unpacked" -
456 "--max-count=*" - "--skip=*" - "--since=*" - "--after=*" -
457 "--until=*" - "--before=*" - "--max-age=*" - "--min-age=*" -
458 "--author=*" - "--committer=*" - "--grep=*" - "-[iE]" -
459 "--remove-empty" - "--first-parent" - "--cherry-pick" -
460 "-S*" - "-G*" - "--pickaxe-all" - "--pickaxe-regex" -
461 "--simplify-by-decoration" {
462 # These mean that we get a subset of the commits
463 set filtered 1
464 lappend glflags $arg
465 }
466 "-L*" {
467 # Line-log with 'stuck' argument (unstuck form is
468 # not supported)
469 set filtered 1
470 set vinlinediff($n) 1
471 set allknown 0
472 lappend glflags $arg
473 }
474 "-n" {
475 # This appears to be the only one that has a value as a
476 # separate word following it
477 set filtered 1
478 set nextisval 1
479 lappend glflags $arg
480 }
481 "--not" - "--all" {
482 lappend revargs $arg
483 }
484 "--merge" {
485 set vmergeonly($n) 1
486 # git rev-parse doesn't understand --merge
487 lappend revargs --gitk-symmetric-diff-marker MERGE_HEAD...HEAD
488 }
489 "--no-replace-objects" {
490 set env(GIT_NO_REPLACE_OBJECTS) "1"
491 }
492 "-*" {
493 # Other flag arguments including -<n>
494 if {[string is digit -strict [string range $arg 1 end]]} {
495 set filtered 1
496 } else {
497 # a flag argument that we don't recognize;
498 # that means we can't optimize
499 set allknown 0
500 }
501 lappend glflags $arg
502 }
503 default {
504 # Non-flag arguments specify commits or ranges of commits
505 if {[string match "*...*" $arg]} {
506 lappend revargs --gitk-symmetric-diff-marker
507 }
508 lappend revargs $arg
509 }
510 }
511 }
512 set vdflags($n) $diffargs
513 set vflags($n) $glflags
514 set vrevs($n) $revargs
515 set vfiltered($n) $filtered
516 set vorigargs($n) $origargs
517 return $allknown
518}
519
520proc parseviewrevs {view revs} {
521 global vposids vnegids
522 global hashlength
523
524 if {$revs eq {}} {
525 set revs HEAD
526 } elseif {[lsearch -exact $revs --all] >= 0} {
527 lappend revs HEAD
528 }
529 if {[catch {set ids [safe_exec [concat git rev-parse $revs]]} err]} {
530 # we get stdout followed by stderr in $err
531 # for an unknown rev, git rev-parse echoes it and then errors out
532 set errlines [split $err "\n"]
533 set badrev {}
534 for {set l 0} {$l < [llength $errlines]} {incr l} {
535 set line [lindex $errlines $l]
536 if {!([string length $line] == $hashlength && [string is xdigit $line])} {
537 if {[string match "fatal:*" $line]} {
538 if {[string match "fatal: ambiguous argument*" $line]
539 && $badrev ne {}} {
540 if {[llength $badrev] == 1} {
541 set err "unknown revision $badrev"
542 } else {
543 set err "unknown revisions: [join $badrev ", "]"
544 }
545 } else {
546 set err [join [lrange $errlines $l end] "\n"]
547 }
548 break
549 }
550 lappend badrev $line
551 }
552 }
553 error_popup "[mc "Error parsing revisions:"] $err"
554 return {}
555 }
556 set ret {}
557 set pos {}
558 set neg {}
559 set sdm 0
560 foreach id [split $ids "\n"] {
561 if {$id eq "--gitk-symmetric-diff-marker"} {
562 set sdm 4
563 } elseif {[string match "^*" $id]} {
564 if {$sdm != 1} {
565 lappend ret $id
566 if {$sdm == 3} {
567 set sdm 0
568 }
569 }
570 lappend neg [string range $id 1 end]
571 } else {
572 if {$sdm != 2} {
573 lappend ret $id
574 } else {
575 lset ret end $id...[lindex $ret end]
576 }
577 lappend pos $id
578 }
579 incr sdm -1
580 }
581 set vposids($view) $pos
582 set vnegids($view) $neg
583 return $ret
584}
585
586# Start off a git log process and arrange to read its output
587proc start_rev_list {view} {
588 global startmsecs commitidx viewcomplete curview
589 global tclencoding
590 global viewargs viewargscmd viewfiles vfilelimit
591 global showlocalchanges
592 global viewactive viewinstances vmergeonly
593 global mainheadid viewmainheadid viewmainheadid_orig
594 global vcanopt vflags vrevs vorigargs
595
596 set startmsecs [clock clicks -milliseconds]
597 set commitidx($view) 0
598 # these are set this way for the error exits
599 set viewcomplete($view) 1
600 set viewactive($view) 0
601 varcinit $view
602
603 set args $viewargs($view)
604 if {$viewargscmd($view) ne {}} {
605 if {[catch {
606 set str [safe_exec [list sh -c $viewargscmd($view)]]
607 } err]} {
608 error_popup "[mc "Error executing --argscmd command:"] $err"
609 return 0
610 }
611 set args [concat $args [split $str "\n"]]
612 }
613 set vcanopt($view) [parseviewargs $view $args]
614
615 set files $viewfiles($view)
616 if {$vmergeonly($view)} {
617 set files [unmerged_files $files]
618 if {$files eq {}} {
619 global nr_unmerged
620 if {$nr_unmerged == 0} {
621 error_popup [mc "No files selected: --merge specified but\
622 no files are unmerged."]
623 } else {
624 error_popup [mc "No files selected: --merge specified but\
625 no unmerged files are within file limit."]
626 }
627 return 0
628 }
629 }
630 set vfilelimit($view) $files
631
632 if {$vcanopt($view)} {
633 set revs [parseviewrevs $view $vrevs($view)]
634 if {$revs eq {}} {
635 return 0
636 }
637 set args $vflags($view)
638 } else {
639 set revs {}
640 set args $vorigargs($view)
641 }
642
643 if {[catch {
644 set fd [safe_open_command_redirect [concat git log --no-color -z --pretty=raw --show-notes \
645 --parents --boundary $args --stdin] \
646 [list "<<[join [concat $revs "--" $files] "\n"]"]]
647 } err]} {
648 error_popup "[mc "Error executing git log:"] $err"
649 return 0
650 }
651 set i [reg_instance $fd]
652 set viewinstances($view) [list $i]
653 set viewmainheadid($view) $mainheadid
654 set viewmainheadid_orig($view) $mainheadid
655 if {$files ne {} && $mainheadid ne {}} {
656 get_viewmainhead $view
657 }
658 if {$showlocalchanges && $viewmainheadid($view) ne {}} {
659 interestedin $viewmainheadid($view) dodiffindex
660 }
661 fconfigure $fd -blocking 0 -translation lf -eofchar {}
662 if {$tclencoding != {}} {
663 fconfigure $fd -encoding $tclencoding
664 }
665 filerun $fd [list getcommitlines $fd $i $view 0]
666 nowbusy $view [mc "Reading"]
667 set viewcomplete($view) 0
668 set viewactive($view) 1
669 return 1
670}
671
672proc stop_instance {inst} {
673 global commfd leftover
674
675 set fd $commfd($inst)
676 catch {
677 set pid [pid $fd]
678
679 if {$::tcl_platform(platform) eq {windows}} {
680 safe_exec [list taskkill /pid $pid]
681 } else {
682 safe_exec [list kill $pid]
683 }
684 }
685 catch {close $fd}
686 nukefile $fd
687 unset commfd($inst)
688 unset leftover($inst)
689}
690
691proc stop_backends {} {
692 global commfd
693
694 foreach inst [array names commfd] {
695 stop_instance $inst
696 }
697}
698
699proc stop_rev_list {view} {
700 global viewinstances
701
702 foreach inst $viewinstances($view) {
703 stop_instance $inst
704 }
705 set viewinstances($view) {}
706}
707
708proc reset_pending_select {selid} {
709 global pending_select mainheadid selectheadid
710
711 if {$selid ne {}} {
712 set pending_select $selid
713 } elseif {$selectheadid ne {}} {
714 set pending_select $selectheadid
715 } else {
716 set pending_select $mainheadid
717 }
718}
719
720proc getcommits {selid} {
721 global canv curview need_redisplay viewactive
722
723 initlayout
724 if {[start_rev_list $curview]} {
725 reset_pending_select $selid
726 show_status [mc "Reading commits..."]
727 set need_redisplay 1
728 } else {
729 show_status [mc "No commits selected"]
730 }
731}
732
733proc updatecommits {} {
734 global curview vcanopt vorigargs vfilelimit viewinstances
735 global viewactive viewcomplete tclencoding
736 global startmsecs showneartags showlocalchanges
737 global mainheadid viewmainheadid viewmainheadid_orig pending_select
738 global hasworktree
739 global varcid vposids vnegids vflags vrevs
740 global hashlength
741
742 set hasworktree [hasworktree]
743 rereadrefs
744 set view $curview
745 if {$mainheadid ne $viewmainheadid_orig($view)} {
746 if {$showlocalchanges} {
747 dohidelocalchanges
748 }
749 set viewmainheadid($view) $mainheadid
750 set viewmainheadid_orig($view) $mainheadid
751 if {$vfilelimit($view) ne {}} {
752 get_viewmainhead $view
753 }
754 }
755 if {$showlocalchanges} {
756 doshowlocalchanges
757 }
758 if {$vcanopt($view)} {
759 set oldpos $vposids($view)
760 set oldneg $vnegids($view)
761 set revs [parseviewrevs $view $vrevs($view)]
762 if {$revs eq {}} {
763 return
764 }
765 # note: getting the delta when negative refs change is hard,
766 # and could require multiple git log invocations, so in that
767 # case we ask git log for all the commits (not just the delta)
768 if {$oldneg eq $vnegids($view)} {
769 set newrevs {}
770 set npos 0
771 # take out positive refs that we asked for before or
772 # that we have already seen
773 foreach rev $revs {
774 if {[string length $rev] == $hashlength} {
775 if {[lsearch -exact $oldpos $rev] < 0
776 && ![info exists varcid($view,$rev)]} {
777 lappend newrevs $rev
778 incr npos
779 }
780 } else {
781 lappend $newrevs $rev
782 }
783 }
784 if {$npos == 0} return
785 set revs $newrevs
786 set vposids($view) [lsort -unique [concat $oldpos $vposids($view)]]
787 }
788 set args $vflags($view)
789 foreach r $oldpos {
790 lappend revs "^$r"
791 }
792 } else {
793 set revs {}
794 set args $vorigargs($view)
795 }
796 if {[catch {
797 set fd [safe_open_command_redirect [concat git log --no-color -z --pretty=raw --show-notes \
798 --parents --boundary $args --stdin] \
799 [list "<<[join [concat $revs "--" $vfilelimit($view)] "\n"]"]]
800 } err]} {
801 error_popup "[mc "Error executing git log:"] $err"
802 return
803 }
804 if {$viewactive($view) == 0} {
805 set startmsecs [clock clicks -milliseconds]
806 }
807 set i [reg_instance $fd]
808 lappend viewinstances($view) $i
809 fconfigure $fd -blocking 0 -translation lf -eofchar {}
810 if {$tclencoding != {}} {
811 fconfigure $fd -encoding $tclencoding
812 }
813 filerun $fd [list getcommitlines $fd $i $view 1]
814 incr viewactive($view)
815 set viewcomplete($view) 0
816 reset_pending_select {}
817 nowbusy $view [mc "Reading"]
818 if {$showneartags} {
819 getallcommits
820 }
821}
822
823proc reloadcommits {} {
824 global curview viewcomplete selectedline currentid thickerline
825 global showneartags treediffs commitinterest cached_commitrow
826 global targetid commitinfo
827
828 set selid {}
829 if {$selectedline ne {}} {
830 set selid $currentid
831 }
832
833 if {!$viewcomplete($curview)} {
834 stop_rev_list $curview
835 }
836 resetvarcs $curview
837 set selectedline {}
838 unset -nocomplain currentid
839 unset -nocomplain thickerline
840 unset -nocomplain treediffs
841 readrefs
842 changedrefs
843 if {$showneartags} {
844 getallcommits
845 }
846 clear_display
847 unset -nocomplain commitinfo
848 unset -nocomplain commitinterest
849 unset -nocomplain cached_commitrow
850 unset -nocomplain targetid
851 setcanvscroll
852 getcommits $selid
853 return 0
854}
855
856# This makes a string representation of a positive integer which
857# sorts as a string in numerical order
858proc strrep {n} {
859 if {$n < 16} {
860 return [format "%x" $n]
861 } elseif {$n < 256} {
862 return [format "x%.2x" $n]
863 } elseif {$n < 65536} {
864 return [format "y%.4x" $n]
865 }
866 return [format "z%.8x" $n]
867}
868
869# Procedures used in reordering commits from git log (without
870# --topo-order) into the order for display.
871
872proc varcinit {view} {
873 global varcstart vupptr vdownptr vleftptr vbackptr varctok varcrow
874 global vtokmod varcmod vrowmod varcix vlastins
875
876 set varcstart($view) {{}}
877 set vupptr($view) {0}
878 set vdownptr($view) {0}
879 set vleftptr($view) {0}
880 set vbackptr($view) {0}
881 set varctok($view) {{}}
882 set varcrow($view) {{}}
883 set vtokmod($view) {}
884 set varcmod($view) 0
885 set vrowmod($view) 0
886 set varcix($view) {{}}
887 set vlastins($view) {0}
888}
889
890proc resetvarcs {view} {
891 global varcid varccommits parents children vseedcount ordertok
892 global vshortids
893
894 foreach vid [array names varcid $view,*] {
895 unset varcid($vid)
896 unset children($vid)
897 unset parents($vid)
898 }
899 foreach vid [array names vshortids $view,*] {
900 unset vshortids($vid)
901 }
902 # some commits might have children but haven't been seen yet
903 foreach vid [array names children $view,*] {
904 unset children($vid)
905 }
906 foreach va [array names varccommits $view,*] {
907 unset varccommits($va)
908 }
909 foreach vd [array names vseedcount $view,*] {
910 unset vseedcount($vd)
911 }
912 unset -nocomplain ordertok
913}
914
915# returns a list of the commits with no children
916proc seeds {v} {
917 global vdownptr vleftptr varcstart
918
919 set ret {}
920 set a [lindex $vdownptr($v) 0]
921 while {$a != 0} {
922 lappend ret [lindex $varcstart($v) $a]
923 set a [lindex $vleftptr($v) $a]
924 }
925 return $ret
926}
927
928proc newvarc {view id} {
929 global varcid varctok parents children vdatemode
930 global vupptr vdownptr vleftptr vbackptr varcrow varcix varcstart
931 global commitdata commitinfo vseedcount varccommits vlastins
932
933 set a [llength $varctok($view)]
934 set vid $view,$id
935 if {[llength $children($vid)] == 0 || $vdatemode($view)} {
936 if {![info exists commitinfo($id)]} {
937 parsecommit $id $commitdata($id) 1
938 }
939 set cdate [lindex [lindex $commitinfo($id) 4] 0]
940 if {![string is integer -strict $cdate]} {
941 set cdate 0
942 }
943 if {![info exists vseedcount($view,$cdate)]} {
944 set vseedcount($view,$cdate) -1
945 }
946 set c [incr vseedcount($view,$cdate)]
947 set cdate [expr {$cdate ^ 0xffffffff}]
948 set tok "s[strrep $cdate][strrep $c]"
949 } else {
950 set tok {}
951 }
952 set ka 0
953 if {[llength $children($vid)] > 0} {
954 set kid [lindex $children($vid) end]
955 set k $varcid($view,$kid)
956 if {[string compare [lindex $varctok($view) $k] $tok] > 0} {
957 set ki $kid
958 set ka $k
959 set tok [lindex $varctok($view) $k]
960 }
961 }
962 if {$ka != 0} {
963 set i [lsearch -exact $parents($view,$ki) $id]
964 set j [expr {[llength $parents($view,$ki)] - 1 - $i}]
965 append tok [strrep $j]
966 }
967 set c [lindex $vlastins($view) $ka]
968 if {$c == 0 || [string compare $tok [lindex $varctok($view) $c]] < 0} {
969 set c $ka
970 set b [lindex $vdownptr($view) $ka]
971 } else {
972 set b [lindex $vleftptr($view) $c]
973 }
974 while {$b != 0 && [string compare $tok [lindex $varctok($view) $b]] >= 0} {
975 set c $b
976 set b [lindex $vleftptr($view) $c]
977 }
978 if {$c == $ka} {
979 lset vdownptr($view) $ka $a
980 lappend vbackptr($view) 0
981 } else {
982 lset vleftptr($view) $c $a
983 lappend vbackptr($view) $c
984 }
985 lset vlastins($view) $ka $a
986 lappend vupptr($view) $ka
987 lappend vleftptr($view) $b
988 if {$b != 0} {
989 lset vbackptr($view) $b $a
990 }
991 lappend varctok($view) $tok
992 lappend varcstart($view) $id
993 lappend vdownptr($view) 0
994 lappend varcrow($view) {}
995 lappend varcix($view) {}
996 set varccommits($view,$a) {}
997 lappend vlastins($view) 0
998 return $a
999}
1000
1001proc splitvarc {p v} {
1002 global varcid varcstart varccommits varctok vtokmod
1003 global vupptr vdownptr vleftptr vbackptr varcix varcrow vlastins
1004
1005 set oa $varcid($v,$p)
1006 set otok [lindex $varctok($v) $oa]
1007 set ac $varccommits($v,$oa)
1008 set i [lsearch -exact $varccommits($v,$oa) $p]
1009 if {$i <= 0} return
1010 set na [llength $varctok($v)]
1011 # "%" sorts before "0"...
1012 set tok "$otok%[strrep $i]"
1013 lappend varctok($v) $tok
1014 lappend varcrow($v) {}
1015 lappend varcix($v) {}
1016 set varccommits($v,$oa) [lrange $ac 0 [expr {$i - 1}]]
1017 set varccommits($v,$na) [lrange $ac $i end]
1018 lappend varcstart($v) $p
1019 foreach id $varccommits($v,$na) {
1020 set varcid($v,$id) $na
1021 }
1022 lappend vdownptr($v) [lindex $vdownptr($v) $oa]
1023 lappend vlastins($v) [lindex $vlastins($v) $oa]
1024 lset vdownptr($v) $oa $na
1025 lset vlastins($v) $oa 0
1026 lappend vupptr($v) $oa
1027 lappend vleftptr($v) 0
1028 lappend vbackptr($v) 0
1029 for {set b [lindex $vdownptr($v) $na]} {$b != 0} {set b [lindex $vleftptr($v) $b]} {
1030 lset vupptr($v) $b $na
1031 }
1032 if {[string compare $otok $vtokmod($v)] <= 0} {
1033 modify_arc $v $oa
1034 }
1035}
1036
1037proc renumbervarc {a v} {
1038 global parents children varctok varcstart varccommits
1039 global vupptr vdownptr vleftptr vbackptr vlastins varcid vtokmod vdatemode
1040
1041 set t1 [clock clicks -milliseconds]
1042 set todo {}
1043 set isrelated($a) 1
1044 set kidchanged($a) 1
1045 set ntot 0
1046 while {$a != 0} {
1047 if {[info exists isrelated($a)]} {
1048 lappend todo $a
1049 set id [lindex $varccommits($v,$a) end]
1050 foreach p $parents($v,$id) {
1051 if {[info exists varcid($v,$p)]} {
1052 set isrelated($varcid($v,$p)) 1
1053 }
1054 }
1055 }
1056 incr ntot
1057 set b [lindex $vdownptr($v) $a]
1058 if {$b == 0} {
1059 while {$a != 0} {
1060 set b [lindex $vleftptr($v) $a]
1061 if {$b != 0} break
1062 set a [lindex $vupptr($v) $a]
1063 }
1064 }
1065 set a $b
1066 }
1067 foreach a $todo {
1068 if {![info exists kidchanged($a)]} continue
1069 set id [lindex $varcstart($v) $a]
1070 if {[llength $children($v,$id)] > 1} {
1071 set children($v,$id) [lsort -command [list vtokcmp $v] \
1072 $children($v,$id)]
1073 }
1074 set oldtok [lindex $varctok($v) $a]
1075 if {!$vdatemode($v)} {
1076 set tok {}
1077 } else {
1078 set tok $oldtok
1079 }
1080 set ka 0
1081 set kid [last_real_child $v,$id]
1082 if {$kid ne {}} {
1083 set k $varcid($v,$kid)
1084 if {[string compare [lindex $varctok($v) $k] $tok] > 0} {
1085 set ki $kid
1086 set ka $k
1087 set tok [lindex $varctok($v) $k]
1088 }
1089 }
1090 if {$ka != 0} {
1091 set i [lsearch -exact $parents($v,$ki) $id]
1092 set j [expr {[llength $parents($v,$ki)] - 1 - $i}]
1093 append tok [strrep $j]
1094 }
1095 if {$tok eq $oldtok} {
1096 continue
1097 }
1098 set id [lindex $varccommits($v,$a) end]
1099 foreach p $parents($v,$id) {
1100 if {[info exists varcid($v,$p)]} {
1101 set kidchanged($varcid($v,$p)) 1
1102 } else {
1103 set sortkids($p) 1
1104 }
1105 }
1106 lset varctok($v) $a $tok
1107 set b [lindex $vupptr($v) $a]
1108 if {$b != $ka} {
1109 if {[string compare [lindex $varctok($v) $ka] $vtokmod($v)] < 0} {
1110 modify_arc $v $ka
1111 }
1112 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1113 modify_arc $v $b
1114 }
1115 set c [lindex $vbackptr($v) $a]
1116 set d [lindex $vleftptr($v) $a]
1117 if {$c == 0} {
1118 lset vdownptr($v) $b $d
1119 } else {
1120 lset vleftptr($v) $c $d
1121 }
1122 if {$d != 0} {
1123 lset vbackptr($v) $d $c
1124 }
1125 if {[lindex $vlastins($v) $b] == $a} {
1126 lset vlastins($v) $b $c
1127 }
1128 lset vupptr($v) $a $ka
1129 set c [lindex $vlastins($v) $ka]
1130 if {$c == 0 || \
1131 [string compare $tok [lindex $varctok($v) $c]] < 0} {
1132 set c $ka
1133 set b [lindex $vdownptr($v) $ka]
1134 } else {
1135 set b [lindex $vleftptr($v) $c]
1136 }
1137 while {$b != 0 && \
1138 [string compare $tok [lindex $varctok($v) $b]] >= 0} {
1139 set c $b
1140 set b [lindex $vleftptr($v) $c]
1141 }
1142 if {$c == $ka} {
1143 lset vdownptr($v) $ka $a
1144 lset vbackptr($v) $a 0
1145 } else {
1146 lset vleftptr($v) $c $a
1147 lset vbackptr($v) $a $c
1148 }
1149 lset vleftptr($v) $a $b
1150 if {$b != 0} {
1151 lset vbackptr($v) $b $a
1152 }
1153 lset vlastins($v) $ka $a
1154 }
1155 }
1156 foreach id [array names sortkids] {
1157 if {[llength $children($v,$id)] > 1} {
1158 set children($v,$id) [lsort -command [list vtokcmp $v] \
1159 $children($v,$id)]
1160 }
1161 }
1162 set t2 [clock clicks -milliseconds]
1163 #puts "renumbervarc did [llength $todo] of $ntot arcs in [expr {$t2-$t1}]ms"
1164}
1165
1166# Fix up the graph after we have found out that in view $v,
1167# $p (a commit that we have already seen) is actually the parent
1168# of the last commit in arc $a.
1169proc fix_reversal {p a v} {
1170 global varcid varcstart varctok vupptr
1171
1172 set pa $varcid($v,$p)
1173 if {$p ne [lindex $varcstart($v) $pa]} {
1174 splitvarc $p $v
1175 set pa $varcid($v,$p)
1176 }
1177 # seeds always need to be renumbered
1178 if {[lindex $vupptr($v) $pa] == 0 ||
1179 [string compare [lindex $varctok($v) $a] \
1180 [lindex $varctok($v) $pa]] > 0} {
1181 renumbervarc $pa $v
1182 }
1183}
1184
1185proc insertrow {id p v} {
1186 global cmitlisted children parents varcid varctok vtokmod
1187 global varccommits ordertok commitidx numcommits curview
1188 global targetid targetrow vshortids
1189
1190 readcommit $id
1191 set vid $v,$id
1192 set cmitlisted($vid) 1
1193 set children($vid) {}
1194 set parents($vid) [list $p]
1195 set a [newvarc $v $id]
1196 set varcid($vid) $a
1197 lappend vshortids($v,[string range $id 0 3]) $id
1198 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] < 0} {
1199 modify_arc $v $a
1200 }
1201 lappend varccommits($v,$a) $id
1202 set vp $v,$p
1203 if {[llength [lappend children($vp) $id]] > 1} {
1204 set children($vp) [lsort -command [list vtokcmp $v] $children($vp)]
1205 unset -nocomplain ordertok
1206 }
1207 fix_reversal $p $a $v
1208 incr commitidx($v)
1209 if {$v == $curview} {
1210 set numcommits $commitidx($v)
1211 setcanvscroll
1212 if {[info exists targetid]} {
1213 if {![comes_before $targetid $p]} {
1214 incr targetrow
1215 }
1216 }
1217 }
1218}
1219
1220proc insertfakerow {id p} {
1221 global varcid varccommits parents children cmitlisted
1222 global commitidx varctok vtokmod targetid targetrow curview numcommits
1223
1224 set v $curview
1225 set a $varcid($v,$p)
1226 set i [lsearch -exact $varccommits($v,$a) $p]
1227 if {$i < 0} {
1228 puts "oops: insertfakerow can't find [shortids $p] on arc $a"
1229 return
1230 }
1231 set children($v,$id) {}
1232 set parents($v,$id) [list $p]
1233 set varcid($v,$id) $a
1234 lappend children($v,$p) $id
1235 set cmitlisted($v,$id) 1
1236 set numcommits [incr commitidx($v)]
1237 # note we deliberately don't update varcstart($v) even if $i == 0
1238 set varccommits($v,$a) [linsert $varccommits($v,$a) $i $id]
1239 modify_arc $v $a $i
1240 if {[info exists targetid]} {
1241 if {![comes_before $targetid $p]} {
1242 incr targetrow
1243 }
1244 }
1245 setcanvscroll
1246 drawvisible
1247}
1248
1249proc removefakerow {id} {
1250 global varcid varccommits parents children commitidx
1251 global varctok vtokmod cmitlisted currentid selectedline
1252 global targetid curview numcommits
1253
1254 set v $curview
1255 if {[llength $parents($v,$id)] != 1} {
1256 puts "oops: removefakerow [shortids $id] has [llength $parents($v,$id)] parents"
1257 return
1258 }
1259 set p [lindex $parents($v,$id) 0]
1260 set a $varcid($v,$id)
1261 set i [lsearch -exact $varccommits($v,$a) $id]
1262 if {$i < 0} {
1263 puts "oops: removefakerow can't find [shortids $id] on arc $a"
1264 return
1265 }
1266 unset varcid($v,$id)
1267 set varccommits($v,$a) [lreplace $varccommits($v,$a) $i $i]
1268 unset parents($v,$id)
1269 unset children($v,$id)
1270 unset cmitlisted($v,$id)
1271 set numcommits [incr commitidx($v) -1]
1272 set j [lsearch -exact $children($v,$p) $id]
1273 if {$j >= 0} {
1274 set children($v,$p) [lreplace $children($v,$p) $j $j]
1275 }
1276 modify_arc $v $a $i
1277 if {[info exist currentid] && $id eq $currentid} {
1278 unset currentid
1279 set selectedline {}
1280 }
1281 if {[info exists targetid] && $targetid eq $id} {
1282 set targetid $p
1283 }
1284 setcanvscroll
1285 drawvisible
1286}
1287
1288proc real_children {vp} {
1289 global children nullid nullid2
1290
1291 set kids {}
1292 foreach id $children($vp) {
1293 if {$id ne $nullid && $id ne $nullid2} {
1294 lappend kids $id
1295 }
1296 }
1297 return $kids
1298}
1299
1300proc first_real_child {vp} {
1301 global children nullid nullid2
1302
1303 foreach id $children($vp) {
1304 if {$id ne $nullid && $id ne $nullid2} {
1305 return $id
1306 }
1307 }
1308 return {}
1309}
1310
1311proc last_real_child {vp} {
1312 global children nullid nullid2
1313
1314 set kids $children($vp)
1315 for {set i [llength $kids]} {[incr i -1] >= 0} {} {
1316 set id [lindex $kids $i]
1317 if {$id ne $nullid && $id ne $nullid2} {
1318 return $id
1319 }
1320 }
1321 return {}
1322}
1323
1324proc vtokcmp {v a b} {
1325 global varctok varcid
1326
1327 return [string compare [lindex $varctok($v) $varcid($v,$a)] \
1328 [lindex $varctok($v) $varcid($v,$b)]]
1329}
1330
1331# This assumes that if lim is not given, the caller has checked that
1332# arc a's token is less than $vtokmod($v)
1333proc modify_arc {v a {lim {}}} {
1334 global varctok vtokmod varcmod varcrow vupptr curview vrowmod varccommits
1335
1336 if {$lim ne {}} {
1337 set c [string compare [lindex $varctok($v) $a] $vtokmod($v)]
1338 if {$c > 0} return
1339 if {$c == 0} {
1340 set r [lindex $varcrow($v) $a]
1341 if {$r ne {} && $vrowmod($v) <= $r + $lim} return
1342 }
1343 }
1344 set vtokmod($v) [lindex $varctok($v) $a]
1345 set varcmod($v) $a
1346 if {$v == $curview} {
1347 while {$a != 0 && [lindex $varcrow($v) $a] eq {}} {
1348 set a [lindex $vupptr($v) $a]
1349 set lim {}
1350 }
1351 set r 0
1352 if {$a != 0} {
1353 if {$lim eq {}} {
1354 set lim [llength $varccommits($v,$a)]
1355 }
1356 set r [expr {[lindex $varcrow($v) $a] + $lim}]
1357 }
1358 set vrowmod($v) $r
1359 undolayout $r
1360 }
1361}
1362
1363proc update_arcrows {v} {
1364 global vtokmod varcmod vrowmod varcrow commitidx currentid selectedline
1365 global varcid vrownum varcorder varcix varccommits
1366 global vupptr vdownptr vleftptr varctok
1367 global displayorder parentlist curview cached_commitrow
1368
1369 if {$vrowmod($v) == $commitidx($v)} return
1370 if {$v == $curview} {
1371 if {[llength $displayorder] > $vrowmod($v)} {
1372 set displayorder [lrange $displayorder 0 [expr {$vrowmod($v) - 1}]]
1373 set parentlist [lrange $parentlist 0 [expr {$vrowmod($v) - 1}]]
1374 }
1375 unset -nocomplain cached_commitrow
1376 }
1377 set narctot [expr {[llength $varctok($v)] - 1}]
1378 set a $varcmod($v)
1379 while {$a != 0 && [lindex $varcix($v) $a] eq {}} {
1380 # go up the tree until we find something that has a row number,
1381 # or we get to a seed
1382 set a [lindex $vupptr($v) $a]
1383 }
1384 if {$a == 0} {
1385 set a [lindex $vdownptr($v) 0]
1386 if {$a == 0} return
1387 set vrownum($v) {0}
1388 set varcorder($v) [list $a]
1389 lset varcix($v) $a 0
1390 lset varcrow($v) $a 0
1391 set arcn 0
1392 set row 0
1393 } else {
1394 set arcn [lindex $varcix($v) $a]
1395 if {[llength $vrownum($v)] > $arcn + 1} {
1396 set vrownum($v) [lrange $vrownum($v) 0 $arcn]
1397 set varcorder($v) [lrange $varcorder($v) 0 $arcn]
1398 }
1399 set row [lindex $varcrow($v) $a]
1400 }
1401 while {1} {
1402 set p $a
1403 incr row [llength $varccommits($v,$a)]
1404 # go down if possible
1405 set b [lindex $vdownptr($v) $a]
1406 if {$b == 0} {
1407 # if not, go left, or go up until we can go left
1408 while {$a != 0} {
1409 set b [lindex $vleftptr($v) $a]
1410 if {$b != 0} break
1411 set a [lindex $vupptr($v) $a]
1412 }
1413 if {$a == 0} break
1414 }
1415 set a $b
1416 incr arcn
1417 lappend vrownum($v) $row
1418 lappend varcorder($v) $a
1419 lset varcix($v) $a $arcn
1420 lset varcrow($v) $a $row
1421 }
1422 set vtokmod($v) [lindex $varctok($v) $p]
1423 set varcmod($v) $p
1424 set vrowmod($v) $row
1425 if {[info exists currentid]} {
1426 set selectedline [rowofcommit $currentid]
1427 }
1428}
1429
1430# Test whether view $v contains commit $id
1431proc commitinview {id v} {
1432 global varcid
1433
1434 return [info exists varcid($v,$id)]
1435}
1436
1437# Return the row number for commit $id in the current view
1438proc rowofcommit {id} {
1439 global varcid varccommits varcrow curview cached_commitrow
1440 global varctok vtokmod
1441
1442 set v $curview
1443 if {![info exists varcid($v,$id)]} {
1444 puts "oops rowofcommit no arc for [shortids $id]"
1445 return {}
1446 }
1447 set a $varcid($v,$id)
1448 if {[string compare [lindex $varctok($v) $a] $vtokmod($v)] >= 0} {
1449 update_arcrows $v
1450 }
1451 if {[info exists cached_commitrow($id)]} {
1452 return $cached_commitrow($id)
1453 }
1454 set i [lsearch -exact $varccommits($v,$a) $id]
1455 if {$i < 0} {
1456 puts "oops didn't find commit [shortids $id] in arc $a"
1457 return {}
1458 }
1459 incr i [lindex $varcrow($v) $a]
1460 set cached_commitrow($id) $i
1461 return $i
1462}
1463
1464# Returns 1 if a is on an earlier row than b, otherwise 0
1465proc comes_before {a b} {
1466 global varcid varctok curview
1467
1468 set v $curview
1469 if {$a eq $b || ![info exists varcid($v,$a)] || \
1470 ![info exists varcid($v,$b)]} {
1471 return 0
1472 }
1473 if {$varcid($v,$a) != $varcid($v,$b)} {
1474 return [expr {[string compare [lindex $varctok($v) $varcid($v,$a)] \
1475 [lindex $varctok($v) $varcid($v,$b)]] < 0}]
1476 }
1477 return [expr {[rowofcommit $a] < [rowofcommit $b]}]
1478}
1479
1480proc bsearch {l elt} {
1481 if {[llength $l] == 0 || $elt <= [lindex $l 0]} {
1482 return 0
1483 }
1484 set lo 0
1485 set hi [llength $l]
1486 while {$hi - $lo > 1} {
1487 set mid [expr {int(($lo + $hi) / 2)}]
1488 set t [lindex $l $mid]
1489 if {$elt < $t} {
1490 set hi $mid
1491 } elseif {$elt > $t} {
1492 set lo $mid
1493 } else {
1494 return $mid
1495 }
1496 }
1497 return $lo
1498}
1499
1500# Make sure rows $start..$end-1 are valid in displayorder and parentlist
1501proc make_disporder {start end} {
1502 global vrownum curview commitidx displayorder parentlist
1503 global varccommits varcorder parents vrowmod varcrow
1504 global d_valid_start d_valid_end
1505
1506 if {$end > $vrowmod($curview)} {
1507 update_arcrows $curview
1508 }
1509 set ai [bsearch $vrownum($curview) $start]
1510 set start [lindex $vrownum($curview) $ai]
1511 set narc [llength $vrownum($curview)]
1512 for {set r $start} {$ai < $narc && $r < $end} {incr ai} {
1513 set a [lindex $varcorder($curview) $ai]
1514 set l [llength $displayorder]
1515 set al [llength $varccommits($curview,$a)]
1516 if {$l < $r + $al} {
1517 if {$l < $r} {
1518 set pad [ntimes [expr {$r - $l}] {}]
1519 set displayorder [concat $displayorder $pad]
1520 set parentlist [concat $parentlist $pad]
1521 } elseif {$l > $r} {
1522 set displayorder [lrange $displayorder 0 [expr {$r - 1}]]
1523 set parentlist [lrange $parentlist 0 [expr {$r - 1}]]
1524 }
1525 foreach id $varccommits($curview,$a) {
1526 lappend displayorder $id
1527 lappend parentlist $parents($curview,$id)
1528 }
1529 } elseif {[lindex $displayorder [expr {$r + $al - 1}]] eq {}} {
1530 set i $r
1531 foreach id $varccommits($curview,$a) {
1532 lset displayorder $i $id
1533 lset parentlist $i $parents($curview,$id)
1534 incr i
1535 }
1536 }
1537 incr r $al
1538 }
1539}
1540
1541proc commitonrow {row} {
1542 global displayorder
1543
1544 set id [lindex $displayorder $row]
1545 if {$id eq {}} {
1546 make_disporder $row [expr {$row + 1}]
1547 set id [lindex $displayorder $row]
1548 }
1549 return $id
1550}
1551
1552proc closevarcs {v} {
1553 global varctok varccommits varcid parents children
1554 global cmitlisted commitidx vtokmod curview numcommits
1555
1556 set missing_parents 0
1557 set scripts {}
1558 set narcs [llength $varctok($v)]
1559 for {set a 1} {$a < $narcs} {incr a} {
1560 set id [lindex $varccommits($v,$a) end]
1561 foreach p $parents($v,$id) {
1562 if {[info exists varcid($v,$p)]} continue
1563 # add p as a new commit
1564 incr missing_parents
1565 set cmitlisted($v,$p) 0
1566 set parents($v,$p) {}
1567 if {[llength $children($v,$p)] == 1 &&
1568 [llength $parents($v,$id)] == 1} {
1569 set b $a
1570 } else {
1571 set b [newvarc $v $p]
1572 }
1573 set varcid($v,$p) $b
1574 if {[string compare [lindex $varctok($v) $b] $vtokmod($v)] < 0} {
1575 modify_arc $v $b
1576 }
1577 lappend varccommits($v,$b) $p
1578 incr commitidx($v)
1579 if {$v == $curview} {
1580 set numcommits $commitidx($v)
1581 }
1582 set scripts [check_interest $p $scripts]
1583 }
1584 }
1585 if {$missing_parents > 0} {
1586 foreach s $scripts {
1587 eval $s
1588 }
1589 }
1590}
1591
1592# Use $rwid as a substitute for $id, i.e. reparent $id's children to $rwid
1593# Assumes we already have an arc for $rwid.
1594proc rewrite_commit {v id rwid} {
1595 global children parents varcid varctok vtokmod varccommits
1596
1597 foreach ch $children($v,$id) {
1598 # make $rwid be $ch's parent in place of $id
1599 set i [lsearch -exact $parents($v,$ch) $id]
1600 if {$i < 0} {
1601 puts "oops rewrite_commit didn't find $id in parent list for $ch"
1602 }
1603 set parents($v,$ch) [lreplace $parents($v,$ch) $i $i $rwid]
1604 # add $ch to $rwid's children and sort the list if necessary
1605 if {[llength [lappend children($v,$rwid) $ch]] > 1} {
1606 set children($v,$rwid) [lsort -command [list vtokcmp $v] \
1607 $children($v,$rwid)]
1608 }
1609 # fix the graph after joining $id to $rwid
1610 set a $varcid($v,$ch)
1611 fix_reversal $rwid $a $v
1612 # parentlist is wrong for the last element of arc $a
1613 # even if displayorder is right, hence the 3rd arg here
1614 modify_arc $v $a [expr {[llength $varccommits($v,$a)] - 1}]
1615 }
1616}
1617
1618# Mechanism for registering a command to be executed when we come
1619# across a particular commit. To handle the case when only the
1620# prefix of the commit is known, the commitinterest array is now
1621# indexed by the first 4 characters of the ID. Each element is a
1622# list of id, cmd pairs.
1623proc interestedin {id cmd} {
1624 global commitinterest
1625
1626 lappend commitinterest([string range $id 0 3]) $id $cmd
1627}
1628
1629proc check_interest {id scripts} {
1630 global commitinterest
1631
1632 set prefix [string range $id 0 3]
1633 if {[info exists commitinterest($prefix)]} {
1634 set newlist {}
1635 foreach {i script} $commitinterest($prefix) {
1636 if {[string match "$i*" $id]} {
1637 lappend scripts [string map [list "%I" $id "%P" $i] $script]
1638 } else {
1639 lappend newlist $i $script
1640 }
1641 }
1642 if {$newlist ne {}} {
1643 set commitinterest($prefix) $newlist
1644 } else {
1645 unset commitinterest($prefix)
1646 }
1647 }
1648 return $scripts
1649}
1650
1651proc getcommitlines {fd inst view updating} {
1652 global cmitlisted leftover
1653 global commitidx commitdata vdatemode
1654 global parents children curview hlview
1655 global idpending ordertok
1656 global varccommits varcid varctok vtokmod vfilelimit vshortids
1657 global hashlength
1658
1659 set stuff [read $fd 500000]
1660 # git log doesn't terminate the last commit with a null...
1661 if {$stuff == {} && $leftover($inst) ne {} && [eof $fd]} {
1662 set stuff "\0"
1663 }
1664 if {$stuff == {}} {
1665 if {![eof $fd]} {
1666 return 1
1667 }
1668 global commfd viewcomplete viewactive viewname
1669 global viewinstances
1670 unset commfd($inst)
1671 set i [lsearch -exact $viewinstances($view) $inst]
1672 if {$i >= 0} {
1673 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
1674 }
1675 # set it blocking so we wait for the process to terminate
1676 fconfigure $fd -blocking 1
1677 if {[catch {close $fd} err]} {
1678 set fv {}
1679 if {$view != $curview} {
1680 set fv " for the \"$viewname($view)\" view"
1681 }
1682 if {[string range $err 0 4] == "usage"} {
1683 set err "Gitk: error reading commits$fv:\
1684 bad arguments to git log."
1685 if {$viewname($view) eq [mc "Command line"]} {
1686 append err \
1687 " (Note: arguments to gitk are passed to git log\
1688 to allow selection of commits to be displayed.)"
1689 }
1690 } else {
1691 set err "Error reading commits$fv: $err"
1692 }
1693 error_popup $err
1694 }
1695 if {[incr viewactive($view) -1] <= 0} {
1696 set viewcomplete($view) 1
1697 # Check if we have seen any ids listed as parents that haven't
1698 # appeared in the list
1699 closevarcs $view
1700 notbusy $view
1701 }
1702 if {$view == $curview} {
1703 run chewcommits
1704 }
1705 return 0
1706 }
1707 set start 0
1708 set gotsome 0
1709 set scripts {}
1710 while 1 {
1711 set i [string first "\0" $stuff $start]
1712 if {$i < 0} {
1713 append leftover($inst) [string range $stuff $start end]
1714 break
1715 }
1716 if {$start == 0} {
1717 set cmit $leftover($inst)
1718 append cmit [string range $stuff 0 [expr {$i - 1}]]
1719 set leftover($inst) {}
1720 } else {
1721 set cmit [string range $stuff $start [expr {$i - 1}]]
1722 }
1723 set start [expr {$i + 1}]
1724 set j [string first "\n" $cmit]
1725 set ok 0
1726 set listed 1
1727 if {$j >= 0 && [string match "commit *" $cmit]} {
1728 set ids [string range $cmit 7 [expr {$j - 1}]]
1729 if {[string match {[-^<>]*} $ids]} {
1730 switch -- [string index $ids 0] {
1731 "-" {set listed 0}
1732 "^" {set listed 2}
1733 "<" {set listed 3}
1734 ">" {set listed 4}
1735 }
1736 set ids [string range $ids 1 end]
1737 }
1738 set ok 1
1739 foreach id $ids {
1740 if {[string length $id] != $hashlength} {
1741 set ok 0
1742 break
1743 }
1744 }
1745 }
1746 if {!$ok} {
1747 set shortcmit $cmit
1748 if {[string length $shortcmit] > 80} {
1749 set shortcmit "[string range $shortcmit 0 80]..."
1750 }
1751 error_popup "[mc "Can't parse git log output:"] {$shortcmit}"
1752 exit 1
1753 }
1754 set id [lindex $ids 0]
1755 set vid $view,$id
1756
1757 lappend vshortids($view,[string range $id 0 3]) $id
1758
1759 if {!$listed && $updating && ![info exists varcid($vid)] &&
1760 $vfilelimit($view) ne {}} {
1761 # git log doesn't rewrite parents for unlisted commits
1762 # when doing path limiting, so work around that here
1763 # by working out the rewritten parent with git rev-list
1764 # and if we already know about it, using the rewritten
1765 # parent as a substitute parent for $id's children.
1766 if {![catch {
1767 set rwid [safe_exec [list git rev-list --first-parent --max-count=1 \
1768 $id -- $vfilelimit($view)]]
1769 }]} {
1770 if {$rwid ne {} && [info exists varcid($view,$rwid)]} {
1771 # use $rwid in place of $id
1772 rewrite_commit $view $id $rwid
1773 continue
1774 }
1775 }
1776 }
1777
1778 set a 0
1779 if {[info exists varcid($vid)]} {
1780 if {$cmitlisted($vid) || !$listed} continue
1781 set a $varcid($vid)
1782 }
1783 if {$listed} {
1784 set olds [lrange $ids 1 end]
1785 } else {
1786 set olds {}
1787 }
1788 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
1789 set cmitlisted($vid) $listed
1790 set parents($vid) $olds
1791 if {![info exists children($vid)]} {
1792 set children($vid) {}
1793 } elseif {$a == 0 && [llength $children($vid)] == 1} {
1794 set k [lindex $children($vid) 0]
1795 if {[llength $parents($view,$k)] == 1 &&
1796 (!$vdatemode($view) ||
1797 $varcid($view,$k) == [llength $varctok($view)] - 1)} {
1798 set a $varcid($view,$k)
1799 }
1800 }
1801 if {$a == 0} {
1802 # new arc
1803 set a [newvarc $view $id]
1804 }
1805 if {[string compare [lindex $varctok($view) $a] $vtokmod($view)] < 0} {
1806 modify_arc $view $a
1807 }
1808 if {![info exists varcid($vid)]} {
1809 set varcid($vid) $a
1810 lappend varccommits($view,$a) $id
1811 incr commitidx($view)
1812 }
1813
1814 set i 0
1815 foreach p $olds {
1816 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
1817 set vp $view,$p
1818 if {[llength [lappend children($vp) $id]] > 1 &&
1819 [vtokcmp $view [lindex $children($vp) end-1] $id] > 0} {
1820 set children($vp) [lsort -command [list vtokcmp $view] \
1821 $children($vp)]
1822 unset -nocomplain ordertok
1823 }
1824 if {[info exists varcid($view,$p)]} {
1825 fix_reversal $p $a $view
1826 }
1827 }
1828 incr i
1829 }
1830
1831 set scripts [check_interest $id $scripts]
1832 set gotsome 1
1833 }
1834 if {$gotsome} {
1835 global numcommits hlview
1836
1837 if {$view == $curview} {
1838 set numcommits $commitidx($view)
1839 run chewcommits
1840 }
1841 if {[info exists hlview] && $view == $hlview} {
1842 # we never actually get here...
1843 run vhighlightmore
1844 }
1845 foreach s $scripts {
1846 eval $s
1847 }
1848 }
1849 return 2
1850}
1851
1852proc chewcommits {} {
1853 global curview hlview viewcomplete
1854 global pending_select
1855
1856 layoutmore
1857 if {$viewcomplete($curview)} {
1858 global commitidx varctok
1859 global numcommits startmsecs
1860
1861 if {[info exists pending_select]} {
1862 update
1863 reset_pending_select {}
1864
1865 if {[commitinview $pending_select $curview]} {
1866 selectline [rowofcommit $pending_select] 1
1867 } else {
1868 set row [first_real_row]
1869 selectline $row 1
1870 }
1871 }
1872 if {$commitidx($curview) > 0} {
1873 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
1874 #puts "overall $ms ms for $numcommits commits"
1875 #puts "[llength $varctok($view)] arcs, $commitidx($view) commits"
1876 } else {
1877 show_status [mc "No commits selected"]
1878 }
1879 notbusy layout
1880 }
1881 return 0
1882}
1883
1884proc do_readcommit {id} {
1885 global tclencoding
1886
1887 # Invoke git-log to handle automatic encoding conversion
1888 set fd [safe_open_command [concat git log --no-color --pretty=raw -1 $id]]
1889 # Read the results using i18n.logoutputencoding
1890 fconfigure $fd -translation lf -eofchar {}
1891 if {$tclencoding != {}} {
1892 fconfigure $fd -encoding $tclencoding
1893 }
1894 set contents [read $fd]
1895 close $fd
1896 # Remove the heading line
1897 regsub {^commit [0-9a-f]+\n} $contents {} contents
1898
1899 return $contents
1900}
1901
1902proc readcommit {id} {
1903 if {[catch {set contents [do_readcommit $id]}]} return
1904 parsecommit $id $contents 1
1905}
1906
1907proc parsecommit {id contents listed} {
1908 global commitinfo
1909
1910 set inhdr 1
1911 set comment {}
1912 set headline {}
1913 set auname {}
1914 set audate {}
1915 set comname {}
1916 set comdate {}
1917 set hdrend [string first "\n\n" $contents]
1918 if {$hdrend < 0} {
1919 # should never happen...
1920 set hdrend [string length $contents]
1921 }
1922 set header [string range $contents 0 [expr {$hdrend - 1}]]
1923 set comment [string range $contents [expr {$hdrend + 2}] end]
1924 foreach line [split $header "\n"] {
1925 set line [split $line " "]
1926 set tag [lindex $line 0]
1927 if {$tag == "author"} {
1928 set audate [lrange $line end-1 end]
1929 set auname [join [lrange $line 1 end-2] " "]
1930 } elseif {$tag == "committer"} {
1931 set comdate [lrange $line end-1 end]
1932 set comname [join [lrange $line 1 end-2] " "]
1933 }
1934 }
1935 set headline {}
1936 # take the first non-blank line of the comment as the headline
1937 set headline [string trimleft $comment]
1938 set i [string first "\n" $headline]
1939 if {$i >= 0} {
1940 set headline [string range $headline 0 $i]
1941 }
1942 set headline [string trimright $headline]
1943 set i [string first "\r" $headline]
1944 if {$i >= 0} {
1945 set headline [string trimright [string range $headline 0 $i]]
1946 }
1947 if {!$listed} {
1948 # git log indents the comment by 4 spaces;
1949 # if we got this via git cat-file, add the indentation
1950 set newcomment {}
1951 foreach line [split $comment "\n"] {
1952 append newcomment " "
1953 append newcomment $line
1954 append newcomment "\n"
1955 }
1956 set comment $newcomment
1957 }
1958 set hasnote [string first "\nNotes:\n" $contents]
1959 set diff ""
1960 # If there is diff output shown in the git-log stream, split it
1961 # out. But get rid of the empty line that always precedes the
1962 # diff.
1963 set i [string first "\n\ndiff" $comment]
1964 if {$i >= 0} {
1965 set diff [string range $comment $i+1 end]
1966 set comment [string range $comment 0 $i-1]
1967 }
1968 set commitinfo($id) [list $headline $auname $audate \
1969 $comname $comdate $comment $hasnote $diff]
1970}
1971
1972proc getcommit {id} {
1973 global commitdata commitinfo
1974
1975 if {[info exists commitdata($id)]} {
1976 parsecommit $id $commitdata($id) 1
1977 } else {
1978 readcommit $id
1979 if {![info exists commitinfo($id)]} {
1980 set commitinfo($id) [list [mc "No commit information available"]]
1981 }
1982 }
1983 return 1
1984}
1985
1986# Expand an abbreviated commit ID to a list of full 40-char (or 64-char
1987# for SHA256 repo) IDs that match and are present in the current view.
1988# This is fairly slow...
1989proc longid {prefix} {
1990 global varcid curview vshortids
1991
1992 set ids {}
1993 if {[string length $prefix] >= 4} {
1994 set vshortid $curview,[string range $prefix 0 3]
1995 if {[info exists vshortids($vshortid)]} {
1996 foreach id $vshortids($vshortid) {
1997 if {[string match "$prefix*" $id]} {
1998 if {[lsearch -exact $ids $id] < 0} {
1999 lappend ids $id
2000 if {[llength $ids] >= 2} break
2001 }
2002 }
2003 }
2004 }
2005 } else {
2006 foreach match [array names varcid "$curview,$prefix*"] {
2007 lappend ids [lindex [split $match ","] 1]
2008 if {[llength $ids] >= 2} break
2009 }
2010 }
2011 return $ids
2012}
2013
2014proc readrefs {} {
2015 global tagids idtags headids idheads tagobjid upstreamofref
2016 global otherrefids idotherrefs mainhead mainheadid
2017 global selecthead selectheadid
2018 global hideremotes
2019 global tclencoding
2020 global hashlength
2021
2022 foreach v {tagids idtags headids idheads otherrefids idotherrefs upstreamofref} {
2023 unset -nocomplain $v
2024 }
2025 set refd [safe_open_command [list git show-ref -d]]
2026 if {$tclencoding != {}} {
2027 fconfigure $refd -encoding $tclencoding
2028 }
2029 while {[gets $refd line] >= 0} {
2030 if {[string index $line $hashlength] ne " "} continue
2031 set id [string range $line 0 [expr {$hashlength - 1}]]
2032 set ref [string range $line [expr {$hashlength + 1}] end]
2033 if {![string match "refs/*" $ref]} continue
2034 set name [string range $ref 5 end]
2035 if {[string match "remotes/*" $name]} {
2036 if {![string match "*/HEAD" $name] && !$hideremotes} {
2037 set headids($name) $id
2038 lappend idheads($id) $name
2039 }
2040 } elseif {[string match "heads/*" $name]} {
2041 set name [string range $name 6 end]
2042 set headids($name) $id
2043 lappend idheads($id) $name
2044 } elseif {[string match "tags/*" $name]} {
2045 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
2046 # which is what we want since the former is the commit ID
2047 set name [string range $name 5 end]
2048 if {[string match "*^{}" $name]} {
2049 set name [string range $name 0 end-3]
2050 } else {
2051 set tagobjid($name) $id
2052 }
2053 set tagids($name) $id
2054 lappend idtags($id) $name
2055 } else {
2056 if [is_other_ref_visible $name] {
2057 set otherrefids($name) $id
2058 lappend idotherrefs($id) $name
2059 }
2060 }
2061 }
2062 catch {close $refd}
2063 set mainhead {}
2064 set mainheadid {}
2065 catch {
2066 set mainheadid [exec git rev-parse HEAD]
2067 set thehead [exec git symbolic-ref HEAD]
2068 if {[string match "refs/heads/*" $thehead]} {
2069 set mainhead [string range $thehead 11 end]
2070 }
2071 }
2072 set selectheadid {}
2073 if {$selecthead ne {}} {
2074 catch {
2075 set selectheadid [safe_exec [list git rev-parse --verify $selecthead]]
2076 }
2077 }
2078 #load the local_branch->upstream mapping
2079 # the result of the for-each-ref command produces: local_branch NUL upstream
2080 set refd [safe_open_command [list git for-each-ref {--format=%(refname:short)%00%(upstream)} refs/heads/]]
2081 while {[gets $refd local_tracking] >= 0} {
2082 set line [split $local_tracking \0]
2083 if {[lindex $line 1] ne {}} {
2084 set upstream_ref [string map {"refs/" ""} [lindex $line 1]]
2085 set upstreamofref([lindex $line 0]) $upstream_ref
2086 }
2087 }
2088 catch {close $refd}
2089}
2090
2091# skip over fake commits
2092proc first_real_row {} {
2093 global nullid nullid2 numcommits
2094
2095 for {set row 0} {$row < $numcommits} {incr row} {
2096 set id [commitonrow $row]
2097 if {$id ne $nullid && $id ne $nullid2} {
2098 break
2099 }
2100 }
2101 return $row
2102}
2103
2104# update things for a head moved to a child of its previous location
2105proc movehead {id name} {
2106 global headids idheads
2107
2108 removehead $headids($name) $name
2109 set headids($name) $id
2110 lappend idheads($id) $name
2111}
2112
2113# update things when a head has been removed
2114proc removehead {id name} {
2115 global headids idheads
2116
2117 if {$idheads($id) eq $name} {
2118 unset idheads($id)
2119 } else {
2120 set i [lsearch -exact $idheads($id) $name]
2121 if {$i >= 0} {
2122 set idheads($id) [lreplace $idheads($id) $i $i]
2123 }
2124 }
2125 unset headids($name)
2126}
2127
2128proc ttk_toplevel {w args} {
2129 eval [linsert $args 0 ::toplevel $w]
2130 place [ttk::frame $w._toplevel_background] -x 0 -y 0 -relwidth 1 -relheight 1
2131 return $w
2132}
2133
2134proc make_transient {window origin} {
2135 wm transient $window $origin
2136
2137 # Windows fails to place transient windows normally, so
2138 # schedule a callback to center them on the parent.
2139 if {[tk windowingsystem] eq {win32}} {
2140 after idle [list tk::PlaceWindow $window widget $origin]
2141 }
2142}
2143
2144proc show_error {w top msg} {
2145 if {[wm state $top] eq "withdrawn"} { wm deiconify $top }
2146 message $w.m -text $msg -justify center -aspect 400
2147 pack $w.m -side top -fill x -padx 20 -pady 20
2148 ttk::button $w.ok -default active -text [mc OK] -command "destroy $top"
2149 pack $w.ok -side bottom -fill x
2150 bind $top <Visibility> "grab $top; focus $top"
2151 bind $top <Key-Return> "destroy $top"
2152 bind $top <Key-space> "destroy $top"
2153 bind $top <Key-Escape> "destroy $top"
2154 tkwait window $top
2155}
2156
2157proc error_popup {msg {owner .}} {
2158 if {[tk windowingsystem] eq "win32"} {
2159 tk_messageBox -icon error -type ok -title [wm title .] \
2160 -parent $owner -message $msg
2161 } else {
2162 set w .error
2163 ttk_toplevel $w
2164 make_transient $w $owner
2165 show_error $w $w $msg
2166 }
2167}
2168
2169proc confirm_popup {msg {owner .}} {
2170 global confirm_ok
2171 set confirm_ok 0
2172 set w .confirm
2173 ttk_toplevel $w
2174 make_transient $w $owner
2175 message $w.m -text $msg -justify center -aspect 400
2176 pack $w.m -side top -fill x -padx 20 -pady 20
2177 ttk::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
2178 pack $w.ok -side left -fill x
2179 ttk::button $w.cancel -text [mc Cancel] -command "destroy $w"
2180 pack $w.cancel -side right -fill x
2181 bind $w <Visibility> "grab $w; focus $w"
2182 bind $w <Key-Return> "set confirm_ok 1; destroy $w"
2183 bind $w <Key-space> "set confirm_ok 1; destroy $w"
2184 bind $w <Key-Escape> "destroy $w"
2185 tk::PlaceWindow $w widget $owner
2186 tkwait window $w
2187 return $confirm_ok
2188}
2189
2190proc haveselectionclipboard {} {
2191 return [expr {[tk windowingsystem] eq "x11"}]
2192}
2193
2194proc setoptions {} {
2195 if {[tk windowingsystem] ne "win32"} {
2196 option add *Panedwindow.showHandle 1 startupFile
2197 option add *Panedwindow.sashRelief raised startupFile
2198 if {[tk windowingsystem] ne "aqua"} {
2199 option add *Menu.font uifont startupFile
2200 }
2201 } else {
2202 option add *Menu.TearOff 0 startupFile
2203 }
2204 option add *Button.font uifont startupFile
2205 option add *Checkbutton.font uifont startupFile
2206 option add *Radiobutton.font uifont startupFile
2207 option add *Menubutton.font uifont startupFile
2208 option add *Label.font uifont startupFile
2209 option add *Message.font uifont startupFile
2210 option add *Entry.font textfont startupFile
2211 option add *Text.font textfont startupFile
2212 option add *Labelframe.font uifont startupFile
2213 option add *Spinbox.font textfont startupFile
2214 option add *Listbox.font mainfont startupFile
2215}
2216
2217proc setttkstyle {} {
2218 global theme
2219 eval font configure TkDefaultFont [fontflags mainfont]
2220 eval font configure TkTextFont [fontflags textfont]
2221 eval font configure TkHeadingFont [fontflags mainfont]
2222 eval font configure TkCaptionFont [fontflags mainfont] -weight bold
2223 eval font configure TkTooltipFont [fontflags uifont]
2224 eval font configure TkFixedFont [fontflags textfont]
2225 eval font configure TkIconFont [fontflags uifont]
2226 eval font configure TkMenuFont [fontflags uifont]
2227 eval font configure TkSmallCaptionFont [fontflags uifont]
2228
2229 if {[catch {ttk::style theme use $theme} err]} {
2230 set theme [ttk::style theme use]
2231 }
2232}
2233
2234# Make a menu and submenus.
2235# m is the window name for the menu, items is the list of menu items to add.
2236# Each item is a list {mc label type description options...}
2237# mc is ignored; it's so we can put mc there to alert xgettext
2238# label is the string that appears in the menu
2239# type is cascade, command or radiobutton (should add checkbutton)
2240# description depends on type; it's the sublist for cascade, the
2241# command to invoke for command, or {variable value} for radiobutton
2242proc makemenu {m items} {
2243 menu $m
2244 if {[tk windowingsystem] eq {aqua}} {
2245 set Meta1 Cmd
2246 } else {
2247 set Meta1 Ctrl
2248 }
2249 foreach i $items {
2250 set name [mc [lindex $i 1]]
2251 set type [lindex $i 2]
2252 set thing [lindex $i 3]
2253 set params [list $type]
2254 if {$name ne {}} {
2255 set u [string first "&" [string map {&& x} $name]]
2256 lappend params -label [string map {&& & & {}} $name]
2257 if {$u >= 0} {
2258 lappend params -underline $u
2259 }
2260 }
2261 switch -- $type {
2262 "cascade" {
2263 set submenu [string tolower [string map {& ""} [lindex $i 1]]]
2264 lappend params -menu $m.$submenu
2265 }
2266 "command" {
2267 lappend params -command $thing
2268 }
2269 "radiobutton" {
2270 lappend params -variable [lindex $thing 0] \
2271 -value [lindex $thing 1]
2272 }
2273 }
2274 set tail [lrange $i 4 end]
2275 regsub -all {\yMeta1\y} $tail $Meta1 tail
2276 eval $m add $params $tail
2277 if {$type eq "cascade"} {
2278 makemenu $m.$submenu $thing
2279 }
2280 }
2281}
2282
2283# translate string and remove ampersands
2284proc mca {str} {
2285 return [string map {&& & & {}} [mc $str]]
2286}
2287
2288proc cleardropsel {w} {
2289 $w selection clear
2290}
2291proc makedroplist {w varname args} {
2292 set width 0
2293 foreach label $args {
2294 set cx [string length $label]
2295 if {$cx > $width} {set width $cx}
2296 }
2297 set gm [ttk::combobox $w -width $width -state readonly\
2298 -textvariable $varname -values $args \
2299 -exportselection false]
2300 bind $gm <<ComboboxSelected>> [list $gm selection clear]
2301 return $gm
2302}
2303
2304proc scrollval {D {koff 0}} {
2305 global kscroll scroll_D0
2306 return [expr int(-($D / $scroll_D0) * max(1, $kscroll-$koff))]
2307}
2308
2309proc precisescrollval {D {koff 0}} {
2310 global kscroll
2311 return [expr (-($D / 10.0) * max(1, $kscroll-$koff))]
2312}
2313
2314proc bind_mousewheel {} {
2315 global canv cflist ctext
2316 bindall <MouseWheel> {allcanvs yview scroll [scrollval %D] units}
2317 bindall <Shift-MouseWheel> break
2318 bind $ctext <MouseWheel> {$ctext yview scroll [scrollval %D 2] units}
2319 bind $ctext <Shift-MouseWheel> {$ctext xview scroll [scrollval %D 2] units}
2320 bind $cflist <MouseWheel> {$cflist yview scroll [scrollval %D 2] units}
2321 bind $cflist <Shift-MouseWheel> break
2322 bind $canv <Shift-MouseWheel> {$canv xview scroll [scrollval %D] units}
2323
2324 if {[package vcompare $::tcl_version 8.7] >= 0} {
2325 bindall <Alt-MouseWheel> {allcanvs yview scroll [scrollval 5*%D] units}
2326 bindall <Alt-Shift-MouseWheel> break
2327 bind $ctext <Alt-MouseWheel> {$ctext yview scroll [scrollval 5*%D 2] units}
2328 bind $ctext <Alt-Shift-MouseWheel> {$ctext xview scroll [scrollval 5*%D 2] units}
2329 bind $cflist <Alt-MouseWheel> {$cflist yview scroll [scrollval 5*%D 2] units}
2330 bind $cflist <Alt-Shift-MouseWheel> break
2331 bind $canv <Alt-Shift-MouseWheel> {$canv xview scroll [scrollval 5*%D] units}
2332
2333 bindall <TouchpadScroll> {
2334 lassign [tk::PreciseScrollDeltas %D] deltaX deltaY
2335 allcanvs yview scroll [precisescrollval $deltaY] units
2336 }
2337 bind $ctext <TouchpadScroll> {
2338 lassign [tk::PreciseScrollDeltas %D] deltaX deltaY
2339 $ctext yview scroll [precisescrollval $deltaY 2] units
2340 $ctext xview scroll [precisescrollval $deltaX 2] units
2341 }
2342 bind $cflist <TouchpadScroll> {
2343 lassign [tk::PreciseScrollDeltas %D] deltaX deltaY
2344 $cflist yview scroll [precisescrollval $deltaY 2] units
2345 }
2346 bind $canv <TouchpadScroll> {
2347 lassign [tk::PreciseScrollDeltas %D] deltaX deltaY
2348 $canv xview scroll [precisescrollval $deltaX] units
2349 allcanvs yview scroll [precisescrollval $deltaY] units
2350 }
2351 }
2352}
2353
2354proc bind_mousewheel_buttons {} {
2355 global canv cflist ctext
2356 bindall <ButtonRelease-4> {allcanvs yview scroll [scrollval 1] units}
2357 bindall <ButtonRelease-5> {allcanvs yview scroll [scrollval -1] units}
2358 bindall <Shift-ButtonRelease-4> break
2359 bindall <Shift-ButtonRelease-5> break
2360 bind $ctext <ButtonRelease-4> {$ctext yview scroll [scrollval 1 2] units}
2361 bind $ctext <ButtonRelease-5> {$ctext yview scroll [scrollval -1 2] units}
2362 bind $ctext <Shift-ButtonRelease-4> {$ctext xview scroll [scrollval 1 2] units}
2363 bind $ctext <Shift-ButtonRelease-5> {$ctext xview scroll [scrollval -1 2] units}
2364 bind $cflist <ButtonRelease-4> {$cflist yview scroll [scrollval 1 2] units}
2365 bind $cflist <ButtonRelease-5> {$cflist yview scroll [scrollval -1 2] units}
2366 bind $cflist <Shift-ButtonRelease-4> break
2367 bind $cflist <Shift-ButtonRelease-5> break
2368 bind $canv <Shift-ButtonRelease-4> {$canv xview scroll [scrollval 1] units}
2369 bind $canv <Shift-ButtonRelease-5> {$canv xview scroll [scrollval -1] units}
2370}
2371
2372proc makewindow {} {
2373 global canv canv2 canv3 linespc charspc ctext cflist cscroll
2374 global tabstop
2375 global findtype findtypemenu findloc findstring fstring geometry
2376 global entries sha1entry sha1string sha1but
2377 global diffcontextstring diffcontext
2378 global ignorespace
2379 global maincursor textcursor curtextcursor
2380 global rowctxmenu fakerowmenu mergemax wrapcomment wrapdefault
2381 global highlight_files gdttype
2382 global searchstring sstring
2383 global bgcolor fgcolor bglist fglist diffcolors diffbgcolors selectbgcolor
2384 global filesepbgcolor filesepfgcolor
2385 global mergecolors foundbgcolor currentsearchhitbgcolor
2386 global headctxmenu progresscanv progressitem progresscoords statusw
2387 global fprogitem fprogcoord lastprogupdate progupdatepending
2388 global rprogitem rprogcoord rownumsel numcommits
2389 global worddiff
2390 global hashlength scroll_D0
2391
2392 # The "mc" arguments here are purely so that xgettext
2393 # sees the following string as needing to be translated
2394 set file {
2395 mc "&File" cascade {
2396 {mc "&Update" command updatecommits -accelerator F5}
2397 {mc "&Reload" command reloadcommits -accelerator Shift-F5}
2398 {mc "Reread re&ferences" command rereadrefs}
2399 {mc "&List references" command showrefs -accelerator F2}
2400 {xx "" separator}
2401 {mc "Start git &gui" command {safe_exec_redirect [list git gui] [list &]}}
2402 {xx "" separator}
2403 {mc "&Quit" command doquit -accelerator Meta1-Q}
2404 }}
2405 set edit {
2406 mc "&Edit" cascade {
2407 {mc "&Preferences" command doprefs}
2408 }}
2409 set view {
2410 mc "&View" cascade {
2411 {mc "&New view..." command {newview 0} -accelerator Shift-F4}
2412 {mc "&Edit view..." command editview -state disabled -accelerator F4}
2413 {mc "&Delete view" command delview -state disabled}
2414 {xx "" separator}
2415 {mc "&All files" radiobutton {selectedview 0} -command {showview 0}}
2416 }}
2417 if {[tk windowingsystem] ne "aqua"} {
2418 set help {
2419 mc "&Help" cascade {
2420 {mc "&About gitk" command about}
2421 {mc "&Key bindings" command keys}
2422 }}
2423 set bar [list $file $edit $view $help]
2424 } else {
2425 proc ::tk::mac::ShowPreferences {} {doprefs}
2426 proc ::tk::mac::Quit {} {doquit}
2427 lset file end [lreplace [lindex $file end] end-1 end]
2428 set apple {
2429 xx "&Apple" cascade {
2430 {mc "&About gitk" command about}
2431 {xx "" separator}
2432 }}
2433 set help {
2434 mc "&Help" cascade {
2435 {mc "&Key bindings" command keys}
2436 }}
2437 set bar [list $apple $file $view $help]
2438 }
2439 makemenu .bar $bar
2440 . configure -menu .bar
2441
2442 # cover the non-themed toplevel with a themed frame.
2443 place [ttk::frame ._main_background] -x 0 -y 0 -relwidth 1 -relheight 1
2444
2445 # the gui has upper and lower half, parts of a paned window.
2446 ttk::panedwindow .ctop -orient vertical
2447
2448 # possibly use assumed geometry
2449 if {![info exists geometry(pwsash0)]} {
2450 set geometry(topheight) [expr {15 * $linespc}]
2451 set geometry(topwidth) [expr {80 * $charspc}]
2452 set geometry(botheight) [expr {15 * $linespc}]
2453 set geometry(botwidth) [expr {50 * $charspc}]
2454 set geometry(pwsash0) [list [expr {40 * $charspc}] 2]
2455 set geometry(pwsash1) [list [expr {60 * $charspc}] 2]
2456 }
2457
2458 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
2459 ttk::frame .tf -height $geometry(topheight) -width $geometry(topwidth)
2460 ttk::frame .tf.histframe
2461 ttk::panedwindow .tf.histframe.pwclist -orient horizontal
2462
2463 # create three canvases
2464 set cscroll .tf.histframe.csb
2465 set canv .tf.histframe.pwclist.canv
2466 canvas $canv \
2467 -selectbackground $selectbgcolor \
2468 -background $bgcolor -bd 0 \
2469 -xscrollincr $linespc \
2470 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
2471 .tf.histframe.pwclist add $canv
2472 set canv2 .tf.histframe.pwclist.canv2
2473 canvas $canv2 \
2474 -selectbackground $selectbgcolor \
2475 -background $bgcolor -bd 0 -yscrollincr $linespc
2476 .tf.histframe.pwclist add $canv2
2477 set canv3 .tf.histframe.pwclist.canv3
2478 canvas $canv3 \
2479 -selectbackground $selectbgcolor \
2480 -background $bgcolor -bd 0 -yscrollincr $linespc
2481 .tf.histframe.pwclist add $canv3
2482 bind .tf.histframe.pwclist <Map> {
2483 bind %W <Map> {}
2484 .tf.histframe.pwclist sashpos 1 [lindex $::geometry(pwsash1) 0]
2485 .tf.histframe.pwclist sashpos 0 [lindex $::geometry(pwsash0) 0]
2486 }
2487
2488 # a scroll bar to rule them
2489 ttk::scrollbar $cscroll -command {allcanvs yview}
2490 pack $cscroll -side right -fill y
2491 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
2492 lappend bglist $canv $canv2 $canv3
2493 pack .tf.histframe.pwclist -fill both -expand 1 -side left
2494
2495 # we have two button bars at bottom of top frame. Bar 1
2496 ttk::frame .tf.bar
2497 ttk::frame .tf.lbar -height 15
2498
2499 set sha1entry .tf.bar.sha1
2500 set entries $sha1entry
2501 set sha1but .tf.bar.sha1label
2502 ttk::button $sha1but -text "[mc "Commit ID:"] " -state disabled \
2503 -command gotocommit -width 8
2504 pack .tf.bar.sha1label -side left
2505 ttk::entry $sha1entry -width $hashlength -font textfont -textvariable sha1string
2506 trace add variable sha1string write sha1change
2507 pack $sha1entry -side left -pady 2
2508
2509 ttk::button .tf.bar.leftbut -command goback -state disabled
2510 .tf.bar.leftbut configure -text \u2190 -width 3
2511 pack .tf.bar.leftbut -side left -fill y
2512 ttk::button .tf.bar.rightbut -command goforw -state disabled
2513 .tf.bar.rightbut configure -text \u2192 -width 3
2514 pack .tf.bar.rightbut -side left -fill y
2515
2516 ttk::label .tf.bar.rowlabel -text [mc "Row"]
2517 set rownumsel {}
2518 ttk::label .tf.bar.rownum -width 7 -textvariable rownumsel \
2519 -relief sunken -anchor e
2520 ttk::label .tf.bar.rowlabel2 -text "/"
2521 ttk::label .tf.bar.numcommits -width 7 -textvariable numcommits \
2522 -relief sunken -anchor e
2523 pack .tf.bar.rowlabel .tf.bar.rownum .tf.bar.rowlabel2 .tf.bar.numcommits \
2524 -side left
2525 global selectedline
2526 trace add variable selectedline write selectedline_change
2527
2528 # Status label and progress bar
2529 set statusw .tf.bar.status
2530 ttk::label $statusw -width 15 -relief sunken
2531 pack $statusw -side left -padx 5
2532 set progresscanv [ttk::progressbar .tf.bar.progress]
2533 pack $progresscanv -side right -expand 1 -fill x -padx {0 2}
2534 set progresscoords {0 0}
2535 set fprogcoord 0
2536 set rprogcoord 0
2537 bind $progresscanv <Configure> adjustprogress
2538 set lastprogupdate [clock clicks -milliseconds]
2539 set progupdatepending 0
2540
2541 # build up the bottom bar of upper window
2542 ttk::label .tf.lbar.flabel -text "[mc "Find"] "
2543
2544 ttk::button .tf.lbar.fnext -command {dofind 1 1} -text \u2193 -width 3
2545 ttk::button .tf.lbar.fprev -command {dofind -1 1} -text \u2191 -width 3
2546
2547 ttk::label .tf.lbar.flab2 -text " [mc "commit"] "
2548
2549 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
2550 -side left -fill y
2551 set gdttype [mc "containing:"]
2552 set gm [makedroplist .tf.lbar.gdttype gdttype \
2553 [mc "containing:"] \
2554 [mc "touching paths:"] \
2555 [mc "adding/removing string:"] \
2556 [mc "changing lines matching:"]]
2557 trace add variable gdttype write gdttype_change
2558 pack .tf.lbar.gdttype -side left -fill y
2559
2560 set findstring {}
2561 set fstring .tf.lbar.findstring
2562 lappend entries $fstring
2563 ttk::entry $fstring -width 30 -textvariable findstring
2564 trace add variable findstring write find_change
2565 set findtype [mc "Exact"]
2566 set findtypemenu [makedroplist .tf.lbar.findtype \
2567 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
2568 trace add variable findtype write findcom_change
2569 set findloc [mc "All fields"]
2570 makedroplist .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
2571 [mc "Comments"] [mc "Author"] [mc "Committer"]
2572 trace add variable findloc write find_change
2573 pack .tf.lbar.findloc -side right
2574 pack .tf.lbar.findtype -side right
2575 pack $fstring -side left -expand 1 -fill x
2576
2577 # Finish putting the upper half of the viewer together
2578 pack .tf.lbar -in .tf -side bottom -fill x
2579 pack .tf.bar -in .tf -side bottom -fill x
2580 pack .tf.histframe -fill both -side top -expand 1
2581 .ctop add .tf
2582
2583 # now build up the bottom
2584 ttk::panedwindow .pwbottom -orient horizontal
2585
2586 # lower left, a text box over search bar, scroll bar to the right
2587 # if we know window height, then that will set the lower text height, otherwise
2588 # we set lower text height which will drive window height
2589 if {[info exists geometry(main)]} {
2590 ttk::frame .bleft -width $geometry(botwidth)
2591 } else {
2592 ttk::frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
2593 }
2594 ttk::frame .bleft.top
2595 ttk::frame .bleft.mid
2596 ttk::frame .bleft.bottom
2597
2598 # gap between sub-widgets
2599 set wgap [font measure uifont "i"]
2600
2601 ttk::button .bleft.top.search -text [mc "Search"] -command dosearch
2602 pack .bleft.top.search -side left -padx 5
2603 set sstring .bleft.top.sstring
2604 set searchstring ""
2605 ttk::entry $sstring -width 20 -textvariable searchstring
2606 lappend entries $sstring
2607 trace add variable searchstring write incrsearch
2608 pack $sstring -side left -expand 1 -fill x
2609 ttk::radiobutton .bleft.mid.diff -text [mc "Diff"] \
2610 -command changediffdisp -variable diffelide -value {0 0}
2611 ttk::radiobutton .bleft.mid.old -text [mc "Old version"] \
2612 -command changediffdisp -variable diffelide -value {0 1}
2613 ttk::radiobutton .bleft.mid.new -text [mc "New version"] \
2614 -command changediffdisp -variable diffelide -value {1 0}
2615
2616 ttk::label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
2617 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left -ipadx $wgap
2618 ttk::spinbox .bleft.mid.diffcontext -width 5 \
2619 -from 0 -increment 1 -to 10000000 \
2620 -validate all -validatecommand "diffcontextvalidate %P" \
2621 -textvariable diffcontextstring
2622 .bleft.mid.diffcontext set $diffcontext
2623 trace add variable diffcontextstring write diffcontextchange
2624 lappend entries .bleft.mid.diffcontext
2625 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left -ipadx $wgap
2626 ttk::checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
2627 -command changeignorespace -variable ignorespace
2628 pack .bleft.mid.ignspace -side left -padx 5
2629
2630 set worddiff [mc "Line diff"]
2631 makedroplist .bleft.mid.worddiff worddiff [mc "Line diff"] \
2632 [mc "Markup words"] [mc "Color words"]
2633 trace add variable worddiff write changeworddiff
2634 pack .bleft.mid.worddiff -side left -padx 5
2635
2636 set ctext .bleft.bottom.ctext
2637 text $ctext -background $bgcolor -foreground $fgcolor \
2638 -state disabled -undo 0 -font textfont \
2639 -yscrollcommand scrolltext -wrap $wrapdefault \
2640 -xscrollcommand ".bleft.bottom.sbhorizontal set"
2641 $ctext conf -tabstyle wordprocessor
2642 ttk::scrollbar .bleft.bottom.sb -command "$ctext yview"
2643 ttk::scrollbar .bleft.bottom.sbhorizontal -command "$ctext xview" -orient h
2644 pack .bleft.top -side top -fill x
2645 pack .bleft.mid -side top -fill x
2646 grid $ctext .bleft.bottom.sb -sticky nsew
2647 grid .bleft.bottom.sbhorizontal -sticky ew
2648 grid columnconfigure .bleft.bottom 0 -weight 1
2649 grid rowconfigure .bleft.bottom 0 -weight 1
2650 grid rowconfigure .bleft.bottom 1 -weight 0
2651 pack .bleft.bottom -side top -fill both -expand 1
2652 lappend bglist $ctext
2653 lappend fglist $ctext
2654
2655 $ctext tag conf comment -wrap $wrapcomment
2656 $ctext tag conf filesep -font textfontbold -fore $filesepfgcolor -back $filesepbgcolor
2657 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
2658 $ctext tag conf d0 -fore [lindex $diffcolors 0]
2659 $ctext tag conf d0 -back [lindex $diffbgcolors 0]
2660 $ctext tag conf dresult -fore [lindex $diffcolors 1]
2661 $ctext tag conf dresult -back [lindex $diffbgcolors 1]
2662 $ctext tag conf m0 -fore [lindex $mergecolors 0]
2663 $ctext tag conf m1 -fore [lindex $mergecolors 1]
2664 $ctext tag conf m2 -fore [lindex $mergecolors 2]
2665 $ctext tag conf m3 -fore [lindex $mergecolors 3]
2666 $ctext tag conf m4 -fore [lindex $mergecolors 4]
2667 $ctext tag conf m5 -fore [lindex $mergecolors 5]
2668 $ctext tag conf m6 -fore [lindex $mergecolors 6]
2669 $ctext tag conf m7 -fore [lindex $mergecolors 7]
2670 $ctext tag conf m8 -fore [lindex $mergecolors 8]
2671 $ctext tag conf m9 -fore [lindex $mergecolors 9]
2672 $ctext tag conf m10 -fore [lindex $mergecolors 10]
2673 $ctext tag conf m11 -fore [lindex $mergecolors 11]
2674 $ctext tag conf m12 -fore [lindex $mergecolors 12]
2675 $ctext tag conf m13 -fore [lindex $mergecolors 13]
2676 $ctext tag conf m14 -fore [lindex $mergecolors 14]
2677 $ctext tag conf m15 -fore [lindex $mergecolors 15]
2678 $ctext tag conf mmax -fore darkgrey
2679 set mergemax 16
2680 $ctext tag conf mresult -font textfontbold
2681 $ctext tag conf msep -font textfontbold
2682 $ctext tag conf found -back $foundbgcolor
2683 $ctext tag conf currentsearchhit -back $currentsearchhitbgcolor
2684 $ctext tag conf wwrap -wrap word -lmargin2 1c
2685 $ctext tag conf bold -font textfontbold
2686 # set these to the lowest priority:
2687 $ctext tag lower currentsearchhit
2688 $ctext tag lower found
2689 $ctext tag lower filesep
2690 $ctext tag lower dresult
2691 $ctext tag lower d0
2692
2693 .pwbottom add .bleft
2694
2695 # lower right
2696 ttk::frame .bright
2697 ttk::frame .bright.mode
2698 ttk::radiobutton .bright.mode.patch -text [mc "Patch"] \
2699 -command reselectline -variable cmitmode -value "patch"
2700 ttk::radiobutton .bright.mode.tree -text [mc "Tree"] \
2701 -command reselectline -variable cmitmode -value "tree"
2702 grid .bright.mode.patch .bright.mode.tree -sticky ew
2703 pack .bright.mode -side top -fill x
2704 set cflist .bright.cfiles
2705 set indent [font measure mainfont "nn"]
2706 text $cflist \
2707 -selectbackground $selectbgcolor \
2708 -background $bgcolor -foreground $fgcolor \
2709 -font mainfont \
2710 -tabs [list $indent [expr {2 * $indent}]] \
2711 -yscrollcommand ".bright.sb set" \
2712 -cursor [. cget -cursor] \
2713 -spacing1 1 -spacing3 1
2714 lappend bglist $cflist
2715 lappend fglist $cflist
2716 ttk::scrollbar .bright.sb -command "$cflist yview"
2717 pack .bright.sb -side right -fill y
2718 pack $cflist -side left -fill both -expand 1
2719 $cflist tag configure highlight \
2720 -background [$cflist cget -selectbackground]
2721 $cflist tag configure bold -font mainfontbold
2722
2723 .pwbottom add .bright
2724 .ctop add .pwbottom
2725
2726 # restore window width & height if known
2727 if {[info exists geometry(main)]} {
2728 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
2729 if {$w > [winfo screenwidth .]} {
2730 set w [winfo screenwidth .]
2731 }
2732 if {$h > [winfo screenheight .]} {
2733 set h [winfo screenheight .]
2734 }
2735 wm geometry . "${w}x$h"
2736 }
2737 }
2738
2739 if {[info exists geometry(state)] && $geometry(state) eq "zoomed"} {
2740 wm state . $geometry(state)
2741 }
2742
2743 if {[tk windowingsystem] eq {aqua}} {
2744 set M1B M1
2745 set ::BM "3"
2746 } else {
2747 set M1B Control
2748 set ::BM "2"
2749 }
2750
2751 bind .ctop <Map> {
2752 bind %W <Map> {}
2753 %W sashpos 0 $::geometry(topheight)
2754 }
2755 bind .pwbottom <Map> {
2756 bind %W <Map> {}
2757 %W sashpos 0 $::geometry(botwidth)
2758 }
2759 bind .pwbottom <Configure> {resizecdetpanes %W %w}
2760
2761 pack .ctop -fill both -expand 1
2762 bindall <1> {selcanvline %W %x %y}
2763
2764 #Mouse / touchpad scrolling
2765 if {[tk windowingsystem] == "win32" || [package vcompare $::tcl_version 8.7] >= 0} {
2766 set scroll_D0 120
2767 bind_mousewheel
2768 } elseif {[tk windowingsystem] == "x11"} {
2769 set scroll_D0 1
2770 bind_mousewheel_buttons
2771 } elseif {[tk windowingsystem] == "aqua"} {
2772 set scroll_D0 1
2773 bind_mousewheel
2774 } else {
2775 puts stderr [mc "Unknown windowing system, cannot bind mouse"]
2776 }
2777 bindall <$::BM> "canvscan mark %W %x %y"
2778 bindall <B$::BM-Motion> "canvscan dragto %W %x %y"
2779 bind all <$M1B-Key-w> {destroy [winfo toplevel %W]}
2780 bind . <$M1B-Key-w> doquit
2781 bindkey <Home> selfirstline
2782 bindkey <End> sellastline
2783 bind . <Key-Up> "selnextline -1"
2784 bind . <Key-Down> "selnextline 1"
2785 bind . <Shift-Key-Up> "dofind -1 0"
2786 bind . <Shift-Key-Down> "dofind 1 0"
2787 bindkey <<NextChar>> "goforw"
2788 bindkey <<PrevChar>> "goback"
2789 bind . <Key-Prior> "selnextpage -1"
2790 bind . <Key-Next> "selnextpage 1"
2791 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
2792 bind . <$M1B-End> "allcanvs yview moveto 1.0"
2793 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
2794 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
2795 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
2796 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
2797 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
2798 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
2799 bindkey <Key-space> "$ctext yview scroll 1 pages"
2800 bindkey p "selnextline -1"
2801 bindkey n "selnextline 1"
2802 bindkey z "goback"
2803 bindkey x "goforw"
2804 bindkey k "selnextline -1"
2805 bindkey j "selnextline 1"
2806 bindkey h "goback"
2807 bindkey l "goforw"
2808 bindkey b prevfile
2809 bindkey d "$ctext yview scroll 18 units"
2810 bindkey u "$ctext yview scroll -18 units"
2811 bindkey g {$sha1entry delete 0 end; focus $sha1entry}
2812 bindkey / {focus $fstring}
2813 bindkey <Key-KP_Divide> {focus $fstring}
2814 bindkey <Key-Return> {dofind 1 1}
2815 bindkey ? {dofind -1 1}
2816 bindkey f nextfile
2817 bind . <F5> updatecommits
2818 bindmodfunctionkey Shift 5 reloadcommits
2819 bind . <F2> showrefs
2820 bindmodfunctionkey Shift 4 {newview 0}
2821 bind . <F4> edit_or_newview
2822 bind . <$M1B-q> doquit
2823 bind . <$M1B-f> {dofind 1 1}
2824 bind . <$M1B-g> {dofind 1 0}
2825 bind . <$M1B-r> dosearchback
2826 bind . <$M1B-s> dosearch
2827 bind . <$M1B-equal> {incrfont 1}
2828 bind . <$M1B-plus> {incrfont 1}
2829 bind . <$M1B-KP_Add> {incrfont 1}
2830 bind . <$M1B-minus> {incrfont -1}
2831 bind . <$M1B-KP_Subtract> {incrfont -1}
2832 wm protocol . WM_DELETE_WINDOW doquit
2833 bind . <Destroy> {stop_backends}
2834 bind . <Button-1> "click %W"
2835 bind $fstring <Key-Return> {dofind 1 1}
2836 bind $sha1entry <Key-Return> {gotocommit; break}
2837 bind $sha1entry <<PasteSelection>> clearsha1
2838 bind $sha1entry <<Paste>> clearsha1
2839 bind $cflist <1> {sel_flist %W %x %y; break}
2840 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
2841 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
2842 global ctxbut
2843 bind $cflist $ctxbut {pop_flist_menu %W %X %Y %x %y}
2844 bind $ctext $ctxbut {pop_diff_menu %W %X %Y %x %y}
2845 bind $ctext <Button-1> {focus %W}
2846 bind $ctext <<Selection>> rehighlight_search_results
2847 for {set i 1} {$i < 10} {incr i} {
2848 bind . <$M1B-Key-$i> [list go_to_parent $i]
2849 }
2850
2851 set maincursor [. cget -cursor]
2852 set textcursor [$ctext cget -cursor]
2853 set curtextcursor $textcursor
2854
2855 set rowctxmenu .rowctxmenu
2856 makemenu $rowctxmenu {
2857 {mc "Diff this -> selected" command {diffvssel 0}}
2858 {mc "Diff selected -> this" command {diffvssel 1}}
2859 {mc "Make patch" command mkpatch}
2860 {mc "Create tag" command mktag}
2861 {mc "Copy commit reference" command copyreference}
2862 {mc "Write commit to file" command writecommit}
2863 {mc "Create new branch" command mkbranch}
2864 {mc "Cherry-pick this commit" command cherrypick}
2865 {mc "Reset HEAD branch to here" command resethead}
2866 {mc "Mark this commit" command markhere}
2867 {mc "Return to mark" command gotomark}
2868 {mc "Find descendant of this and mark" command find_common_desc}
2869 {mc "Compare with marked commit" command compare_commits}
2870 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2871 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2872 {mc "Revert this commit" command revert}
2873 }
2874 $rowctxmenu configure -tearoff 0
2875
2876 set fakerowmenu .fakerowmenu
2877 makemenu $fakerowmenu {
2878 {mc "Diff this -> selected" command {diffvssel 0}}
2879 {mc "Diff selected -> this" command {diffvssel 1}}
2880 {mc "Make patch" command mkpatch}
2881 {mc "Diff this -> marked commit" command {diffvsmark 0}}
2882 {mc "Diff marked commit -> this" command {diffvsmark 1}}
2883 }
2884 $fakerowmenu configure -tearoff 0
2885
2886 set headctxmenu .headctxmenu
2887 makemenu $headctxmenu {
2888 {mc "Check out this branch" command cobranch}
2889 {mc "Rename this branch" command mvbranch}
2890 {mc "Remove this branch" command rmbranch}
2891 {mc "Copy branch name" command {clipboard clear; clipboard append $headmenuhead}}
2892 }
2893 $headctxmenu configure -tearoff 0
2894
2895 global flist_menu
2896 set flist_menu .flistctxmenu
2897 makemenu $flist_menu {
2898 {mc "Highlight this too" command {flist_hl 0}}
2899 {mc "Highlight this only" command {flist_hl 1}}
2900 {mc "External diff" command {external_diff}}
2901 {mc "Blame parent commit" command {external_blame 1}}
2902 {mc "Copy path" command {clipboard clear; clipboard append $flist_menu_file}}
2903 }
2904 $flist_menu configure -tearoff 0
2905
2906 global diff_menu
2907 set diff_menu .diffctxmenu
2908 makemenu $diff_menu {
2909 {mc "Show origin of this line" command show_line_source}
2910 {mc "Run git gui blame on this line" command {external_blame_diff}}
2911 }
2912 $diff_menu configure -tearoff 0
2913}
2914
2915# Update row number label when selectedline changes
2916proc selectedline_change {n1 n2 op} {
2917 global selectedline rownumsel
2918
2919 if {$selectedline eq {}} {
2920 set rownumsel {}
2921 } else {
2922 set rownumsel [expr {$selectedline + 1}]
2923 }
2924}
2925
2926# mouse-2 makes all windows scan vertically, but only the one
2927# the cursor is in scans horizontally
2928proc canvscan {op w x y} {
2929 global canv canv2 canv3
2930 foreach c [list $canv $canv2 $canv3] {
2931 if {$c == $w} {
2932 $c scan $op $x $y
2933 } else {
2934 $c scan $op 0 $y
2935 }
2936 }
2937}
2938
2939proc scrollcanv {cscroll f0 f1} {
2940 $cscroll set $f0 $f1
2941 drawvisible
2942 flushhighlights
2943}
2944
2945# when we make a key binding for the toplevel, make sure
2946# it doesn't get triggered when that key is pressed in the
2947# find string entry widget.
2948proc bindkey {ev script} {
2949 global entries
2950 bind . $ev $script
2951 set escript [bind Entry $ev]
2952 if {$escript == {}} {
2953 set escript [bind Entry <Key>]
2954 }
2955 foreach e $entries {
2956 bind $e $ev "$escript; break"
2957 }
2958}
2959
2960proc bindmodfunctionkey {mod n script} {
2961 bind . <$mod-F$n> $script
2962 catch { bind . <$mod-XF86_Switch_VT_$n> $script }
2963}
2964
2965# set the focus back to the toplevel for any click outside
2966# the entry widgets
2967proc click {w} {
2968 global ctext entries
2969 foreach e [concat $entries $ctext] {
2970 if {$w == $e} return
2971 }
2972 focus .
2973}
2974
2975# Adjust the progress bar for a change in requested extent or canvas size
2976proc adjustprogress {} {
2977 global progresscanv
2978 global fprogcoord
2979
2980 $progresscanv configure -value [expr {int($fprogcoord * 100)}]
2981}
2982
2983proc doprogupdate {} {
2984 global lastprogupdate progupdatepending
2985
2986 if {$progupdatepending} {
2987 set progupdatepending 0
2988 set lastprogupdate [clock clicks -milliseconds]
2989 update
2990 }
2991}
2992
2993proc config_check_tmp_exists {tries_left} {
2994 global config_file_tmp
2995
2996 if {[file exists $config_file_tmp]} {
2997 incr tries_left -1
2998 if {$tries_left > 0} {
2999 after 100 [list config_check_tmp_exists $tries_left]
3000 } else {
3001 error_popup "There appears to be a stale $config_file_tmp\
3002 file, which will prevent gitk from saving its configuration on exit.\
3003 Please remove it if it is not being used by any existing gitk process."
3004 }
3005 }
3006}
3007
3008proc config_init_trace {name} {
3009 global config_variable_changed config_variable_original
3010
3011 upvar #0 $name var
3012 set config_variable_changed($name) 0
3013 set config_variable_original($name) $var
3014}
3015
3016proc config_variable_change_cb {name name2 op} {
3017 global config_variable_changed config_variable_original
3018
3019 upvar #0 $name var
3020 if {$op eq "write" &&
3021 (![info exists config_variable_original($name)] ||
3022 $config_variable_original($name) ne $var)} {
3023 set config_variable_changed($name) 1
3024 }
3025}
3026
3027proc savestuff {w} {
3028 global stuffsaved
3029 global config_file config_file_tmp
3030 global config_variables config_variable_changed
3031 global viewchanged
3032
3033 upvar #0 viewname current_viewname
3034 upvar #0 viewfiles current_viewfiles
3035 upvar #0 viewargs current_viewargs
3036 upvar #0 viewargscmd current_viewargscmd
3037 upvar #0 viewperm current_viewperm
3038 upvar #0 nextviewnum current_nextviewnum
3039
3040 if {$stuffsaved} return
3041 if {![winfo viewable .]} return
3042 set remove_tmp 0
3043 if {[catch {
3044 set try_count 0
3045 while {[catch {set f [safe_open_file $config_file_tmp {WRONLY CREAT EXCL}]}]} {
3046 if {[incr try_count] > 50} {
3047 error "Unable to write config file: $config_file_tmp exists"
3048 }
3049 after 100
3050 }
3051 set remove_tmp 1
3052 if {$::tcl_platform(platform) eq {windows}} {
3053 file attributes $config_file_tmp -hidden true
3054 }
3055 if {[file exists $config_file]} {
3056 source $config_file
3057 }
3058 foreach var_name $config_variables {
3059 upvar #0 $var_name var
3060 upvar 0 $var_name old_var
3061 if {!$config_variable_changed($var_name) && [info exists old_var]} {
3062 puts $f [list set $var_name $old_var]
3063 } else {
3064 puts $f [list set $var_name $var]
3065 }
3066 }
3067
3068 puts $f "set geometry(main) [wm geometry .]"
3069 puts $f "set geometry(state) [wm state .]"
3070 puts $f "set geometry(topwidth) [winfo width .tf]"
3071 puts $f "set geometry(topheight) [winfo height .tf]"
3072 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sashpos 0] 1\""
3073 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sashpos 1] 1\""
3074 puts $f "set geometry(botwidth) [winfo width .bleft]"
3075 puts $f "set geometry(botheight) [winfo height .bleft]"
3076
3077 array set view_save {}
3078 array set views {}
3079 if {![info exists permviews]} { set permviews {} }
3080 foreach view $permviews {
3081 set view_save([lindex $view 0]) 1
3082 set views([lindex $view 0]) $view
3083 }
3084 puts -nonewline $f "set permviews {"
3085 for {set v 1} {$v < $current_nextviewnum} {incr v} {
3086 if {$viewchanged($v)} {
3087 if {$current_viewperm($v)} {
3088 set views($current_viewname($v)) [list $current_viewname($v) $current_viewfiles($v) $current_viewargs($v) $current_viewargscmd($v)]
3089 } else {
3090 set view_save($current_viewname($v)) 0
3091 }
3092 }
3093 }
3094 # write old and updated view to their places and append remaining to the end
3095 foreach view $permviews {
3096 set view_name [lindex $view 0]
3097 if {$view_save($view_name)} {
3098 puts $f "{$views($view_name)}"
3099 }
3100 unset views($view_name)
3101 }
3102 foreach view_name [array names views] {
3103 puts $f "{$views($view_name)}"
3104 }
3105 puts $f "}"
3106 close $f
3107 file rename -force $config_file_tmp $config_file
3108 set remove_tmp 0
3109 } err]} {
3110 puts "Error saving config: $err"
3111 }
3112 if {$remove_tmp} {
3113 file delete -force $config_file_tmp
3114 }
3115 set stuffsaved 1
3116}
3117
3118proc resizeclistpanes {win w} {
3119 global oldwidth oldsash
3120 if {[info exists oldwidth($win)]} {
3121 if {[info exists oldsash($win)]} {
3122 set s0 [lindex $oldsash($win) 0]
3123 set s1 [lindex $oldsash($win) 1]
3124 } else {
3125 set s0 [$win sashpos 0]
3126 set s1 [$win sashpos 1]
3127 }
3128 if {$w < 60} {
3129 set sash0 [expr {int($w/2 - 2)}]
3130 set sash1 [expr {int($w*5/6 - 2)}]
3131 } else {
3132 set factor [expr {1.0 * $w / $oldwidth($win)}]
3133 set sash0 [expr {int($factor * [lindex $s0 0])}]
3134 set sash1 [expr {int($factor * [lindex $s1 0])}]
3135 if {$sash0 < 30} {
3136 set sash0 30
3137 }
3138 if {$sash1 < $sash0 + 20} {
3139 set sash1 [expr {$sash0 + 20}]
3140 }
3141 if {$sash1 > $w - 10} {
3142 set sash1 [expr {$w - 10}]
3143 if {$sash0 > $sash1 - 20} {
3144 set sash0 [expr {$sash1 - 20}]
3145 }
3146 }
3147 }
3148 $win sashpos 0 $sash0
3149 $win sashpos 1 $sash1
3150 set oldsash($win) [list $sash0 $sash1]
3151 }
3152 set oldwidth($win) $w
3153}
3154
3155proc resizecdetpanes {win w} {
3156 global oldwidth oldsash
3157 if {[info exists oldwidth($win)]} {
3158 if {[info exists oldsash($win)]} {
3159 set s0 $oldsash($win)
3160 } else {
3161 set s0 [$win sashpos 0]
3162 }
3163 if {$w < 60} {
3164 set sash0 [expr {int($w*3/4 - 2)}]
3165 } else {
3166 set factor [expr {1.0 * $w / $oldwidth($win)}]
3167 set sash0 [expr {int($factor * [lindex $s0 0])}]
3168 if {$sash0 < 45} {
3169 set sash0 45
3170 }
3171 if {$sash0 > $w - 15} {
3172 set sash0 [expr {$w - 15}]
3173 }
3174 }
3175 $win sashpos 0 $sash0
3176 set oldsash($win) $sash0
3177 }
3178 set oldwidth($win) $w
3179}
3180
3181proc allcanvs args {
3182 global canv canv2 canv3
3183 eval $canv $args
3184 eval $canv2 $args
3185 eval $canv3 $args
3186}
3187
3188proc bindall {event action} {
3189 global canv canv2 canv3
3190 bind $canv $event $action
3191 bind $canv2 $event $action
3192 bind $canv3 $event $action
3193}
3194
3195proc about {} {
3196 global bgcolor
3197 set w .about
3198 if {[winfo exists $w]} {
3199 raise $w
3200 return
3201 }
3202 ttk_toplevel $w
3203 wm title $w [mc "About gitk"]
3204 make_transient $w .
3205 message $w.m -text [mc "
3206Gitk - a commit viewer for git
3207
3208Copyright \u00a9 2005-2016 Paul Mackerras
3209
3210Use and redistribute under the terms of the GNU General Public License"] \
3211 -justify center -aspect 400 -border 2 -bg $bgcolor -relief groove
3212 pack $w.m -side top -fill x -padx 2 -pady 2
3213 ttk::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3214 pack $w.ok -side bottom
3215 bind $w <Visibility> "focus $w.ok"
3216 bind $w <Key-Escape> "destroy $w"
3217 bind $w <Key-Return> "destroy $w"
3218 tk::PlaceWindow $w widget .
3219}
3220
3221proc keys {} {
3222 global bgcolor
3223 set w .keys
3224 if {[winfo exists $w]} {
3225 raise $w
3226 return
3227 }
3228 if {[tk windowingsystem] eq {aqua}} {
3229 set M1T Cmd
3230 } else {
3231 set M1T Ctrl
3232 }
3233 ttk_toplevel $w
3234 wm title $w [mc "Gitk key bindings"]
3235 make_transient $w .
3236 message $w.m -text "
3237[mc "Gitk key bindings:"]
3238
3239[mc "<%s-Q> Quit" $M1T]
3240[mc "<%s-W> Close window" $M1T]
3241[mc "<Home> Move to first commit"]
3242[mc "<End> Move to last commit"]
3243[mc "<Up>, p, k Move up one commit"]
3244[mc "<Down>, n, j Move down one commit"]
3245[mc "<Left>, z, h Go back in history list"]
3246[mc "<Right>, x, l Go forward in history list"]
3247[mc "<%s-n> Go to n-th parent of current commit in history list" $M1T]
3248[mc "<PageUp> Move up one page in commit list"]
3249[mc "<PageDown> Move down one page in commit list"]
3250[mc "<%s-Home> Scroll to top of commit list" $M1T]
3251[mc "<%s-End> Scroll to bottom of commit list" $M1T]
3252[mc "<%s-Up> Scroll commit list up one line" $M1T]
3253[mc "<%s-Down> Scroll commit list down one line" $M1T]
3254[mc "<%s-PageUp> Scroll commit list up one page" $M1T]
3255[mc "<%s-PageDown> Scroll commit list down one page" $M1T]
3256[mc "<Shift-Up> Find backwards (upwards, later commits)"]
3257[mc "<Shift-Down> Find forwards (downwards, earlier commits)"]
3258[mc "<Delete>, b Scroll diff view up one page"]
3259[mc "<Backspace> Scroll diff view up one page"]
3260[mc "<Space> Scroll diff view down one page"]
3261[mc "u Scroll diff view up 18 lines"]
3262[mc "d Scroll diff view down 18 lines"]
3263[mc "<%s-F> Find" $M1T]
3264[mc "<%s-G> Move to next find hit" $M1T]
3265[mc "<Return> Move to next find hit"]
3266[mc "g Go to commit"]
3267[mc "/ Focus the search box"]
3268[mc "? Move to previous find hit"]
3269[mc "f Scroll diff view to next file"]
3270[mc "<%s-S> Search for next hit in diff view" $M1T]
3271[mc "<%s-R> Search for previous hit in diff view" $M1T]
3272[mc "<%s-KP+> Increase font size" $M1T]
3273[mc "<%s-plus> Increase font size" $M1T]
3274[mc "<%s-KP-> Decrease font size" $M1T]
3275[mc "<%s-minus> Decrease font size" $M1T]
3276[mc "<F5> Update"]
3277" \
3278 -justify left -bg $bgcolor -border 2 -relief groove
3279 pack $w.m -side top -fill both -padx 2 -pady 2
3280 ttk::button $w.ok -text [mc "Close"] -command "destroy $w" -default active
3281 bind $w <Key-Escape> [list destroy $w]
3282 pack $w.ok -side bottom
3283 bind $w <Visibility> "focus $w.ok"
3284 bind $w <Key-Escape> "destroy $w"
3285 bind $w <Key-Return> "destroy $w"
3286}
3287
3288# Procedures for manipulating the file list window at the
3289# bottom right of the overall window.
3290
3291proc treeview {w l openlevs} {
3292 global treecontents treediropen treeheight treeparent treeindex
3293
3294 set ix 0
3295 set treeindex() 0
3296 set lev 0
3297 set prefix {}
3298 set prefixend -1
3299 set prefendstack {}
3300 set htstack {}
3301 set ht 0
3302 set treecontents() {}
3303 $w conf -state normal
3304 foreach f $l {
3305 while {[string range $f 0 $prefixend] ne $prefix} {
3306 if {$lev <= $openlevs} {
3307 $w mark set e:$treeindex($prefix) "end -1c"
3308 $w mark gravity e:$treeindex($prefix) left
3309 }
3310 set treeheight($prefix) $ht
3311 incr ht [lindex $htstack end]
3312 set htstack [lreplace $htstack end end]
3313 set prefixend [lindex $prefendstack end]
3314 set prefendstack [lreplace $prefendstack end end]
3315 set prefix [string range $prefix 0 $prefixend]
3316 incr lev -1
3317 }
3318 set tail [string range $f [expr {$prefixend+1}] end]
3319 while {[set slash [string first "/" $tail]] >= 0} {
3320 lappend htstack $ht
3321 set ht 0
3322 lappend prefendstack $prefixend
3323 incr prefixend [expr {$slash + 1}]
3324 set d [string range $tail 0 $slash]
3325 lappend treecontents($prefix) $d
3326 set oldprefix $prefix
3327 append prefix $d
3328 set treecontents($prefix) {}
3329 set treeindex($prefix) [incr ix]
3330 set treeparent($prefix) $oldprefix
3331 set tail [string range $tail [expr {$slash+1}] end]
3332 if {$lev <= $openlevs} {
3333 set ht 1
3334 set treediropen($prefix) [expr {$lev < $openlevs}]
3335 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
3336 $w mark set d:$ix "end -1c"
3337 $w mark gravity d:$ix left
3338 set str "\n"
3339 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3340 $w insert end $str
3341 $w image create end -align center -image $bm -padx 1 \
3342 -name a:$ix
3343 $w insert end $d [highlight_tag $prefix]
3344 $w mark set s:$ix "end -1c"
3345 $w mark gravity s:$ix left
3346 }
3347 incr lev
3348 }
3349 if {$tail ne {}} {
3350 if {$lev <= $openlevs} {
3351 incr ht
3352 set str "\n"
3353 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
3354 $w insert end $str
3355 $w insert end $tail [highlight_tag $f]
3356 }
3357 lappend treecontents($prefix) $tail
3358 }
3359 }
3360 while {$htstack ne {}} {
3361 set treeheight($prefix) $ht
3362 incr ht [lindex $htstack end]
3363 set htstack [lreplace $htstack end end]
3364 set prefixend [lindex $prefendstack end]
3365 set prefendstack [lreplace $prefendstack end end]
3366 set prefix [string range $prefix 0 $prefixend]
3367 }
3368 $w conf -state disabled
3369}
3370
3371proc linetoelt {l} {
3372 global treeheight treecontents
3373
3374 set y 2
3375 set prefix {}
3376 while {1} {
3377 foreach e $treecontents($prefix) {
3378 if {$y == $l} {
3379 return "$prefix$e"
3380 }
3381 set n 1
3382 if {[string index $e end] eq "/"} {
3383 set n $treeheight($prefix$e)
3384 if {$y + $n > $l} {
3385 append prefix $e
3386 incr y
3387 break
3388 }
3389 }
3390 incr y $n
3391 }
3392 }
3393}
3394
3395proc highlight_tree {y prefix} {
3396 global treeheight treecontents cflist
3397
3398 foreach e $treecontents($prefix) {
3399 set path $prefix$e
3400 if {[highlight_tag $path] ne {}} {
3401 $cflist tag add bold $y.0 "$y.0 lineend"
3402 }
3403 incr y
3404 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
3405 set y [highlight_tree $y $path]
3406 }
3407 }
3408 return $y
3409}
3410
3411proc treeclosedir {w dir} {
3412 global treediropen treeheight treeparent treeindex
3413
3414 set ix $treeindex($dir)
3415 $w conf -state normal
3416 $w delete s:$ix e:$ix
3417 set treediropen($dir) 0
3418 $w image configure a:$ix -image tri-rt
3419 $w conf -state disabled
3420 set n [expr {1 - $treeheight($dir)}]
3421 while {$dir ne {}} {
3422 incr treeheight($dir) $n
3423 set dir $treeparent($dir)
3424 }
3425}
3426
3427proc treeopendir {w dir} {
3428 global treediropen treeheight treeparent treecontents treeindex
3429
3430 set ix $treeindex($dir)
3431 $w conf -state normal
3432 $w image configure a:$ix -image tri-dn
3433 $w mark set e:$ix s:$ix
3434 $w mark gravity e:$ix right
3435 set lev 0
3436 set str "\n"
3437 set n [llength $treecontents($dir)]
3438 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
3439 incr lev
3440 append str "\t"
3441 incr treeheight($x) $n
3442 }
3443 foreach e $treecontents($dir) {
3444 set de $dir$e
3445 if {[string index $e end] eq "/"} {
3446 set iy $treeindex($de)
3447 $w mark set d:$iy e:$ix
3448 $w mark gravity d:$iy left
3449 $w insert e:$ix $str
3450 set treediropen($de) 0
3451 $w image create e:$ix -align center -image tri-rt -padx 1 \
3452 -name a:$iy
3453 $w insert e:$ix $e [highlight_tag $de]
3454 $w mark set s:$iy e:$ix
3455 $w mark gravity s:$iy left
3456 set treeheight($de) 1
3457 } else {
3458 $w insert e:$ix $str
3459 $w insert e:$ix $e [highlight_tag $de]
3460 }
3461 }
3462 $w mark gravity e:$ix right
3463 $w conf -state disabled
3464 set treediropen($dir) 1
3465 set top [lindex [split [$w index @0,0] .] 0]
3466 set ht [$w cget -height]
3467 set l [lindex [split [$w index s:$ix] .] 0]
3468 if {$l < $top} {
3469 $w yview $l.0
3470 } elseif {$l + $n + 1 > $top + $ht} {
3471 set top [expr {$l + $n + 2 - $ht}]
3472 if {$l < $top} {
3473 set top $l
3474 }
3475 $w yview $top.0
3476 }
3477}
3478
3479proc treeclick {w x y} {
3480 global treediropen cmitmode ctext cflist cflist_top
3481
3482 if {$cmitmode ne "tree"} return
3483 if {![info exists cflist_top]} return
3484 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3485 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3486 $cflist tag add highlight $l.0 "$l.0 lineend"
3487 set cflist_top $l
3488 if {$l == 1} {
3489 $ctext yview 1.0
3490 return
3491 }
3492 set e [linetoelt $l]
3493 if {[string index $e end] ne "/"} {
3494 showfile $e
3495 } elseif {$treediropen($e)} {
3496 treeclosedir $w $e
3497 } else {
3498 treeopendir $w $e
3499 }
3500}
3501
3502proc setfilelist {id} {
3503 global treefilelist cflist jump_to_here
3504
3505 treeview $cflist $treefilelist($id) 0
3506 if {$jump_to_here ne {}} {
3507 set f [lindex $jump_to_here 0]
3508 if {[lsearch -exact $treefilelist($id) $f] >= 0} {
3509 showfile $f
3510 }
3511 }
3512}
3513
3514image create bitmap tri-rt -background black -foreground blue -data {
3515 #define tri-rt_width 13
3516 #define tri-rt_height 13
3517 static unsigned char tri-rt_bits[] = {
3518 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
3519 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
3520 0x00, 0x00};
3521} -maskdata {
3522 #define tri-rt-mask_width 13
3523 #define tri-rt-mask_height 13
3524 static unsigned char tri-rt-mask_bits[] = {
3525 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
3526 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
3527 0x08, 0x00};
3528}
3529image create bitmap tri-dn -background black -foreground blue -data {
3530 #define tri-dn_width 13
3531 #define tri-dn_height 13
3532 static unsigned char tri-dn_bits[] = {
3533 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
3534 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
3535 0x00, 0x00};
3536} -maskdata {
3537 #define tri-dn-mask_width 13
3538 #define tri-dn-mask_height 13
3539 static unsigned char tri-dn-mask_bits[] = {
3540 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
3541 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
3542 0x00, 0x00};
3543}
3544
3545image create bitmap reficon-T -background black -foreground yellow -data {
3546 #define tagicon_width 13
3547 #define tagicon_height 9
3548 static unsigned char tagicon_bits[] = {
3549 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
3550 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
3551} -maskdata {
3552 #define tagicon-mask_width 13
3553 #define tagicon-mask_height 9
3554 static unsigned char tagicon-mask_bits[] = {
3555 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
3556 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
3557}
3558set rectdata {
3559 #define headicon_width 13
3560 #define headicon_height 9
3561 static unsigned char headicon_bits[] = {
3562 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
3563 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
3564}
3565set rectmask {
3566 #define headicon-mask_width 13
3567 #define headicon-mask_height 9
3568 static unsigned char headicon-mask_bits[] = {
3569 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
3570 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
3571}
3572image create bitmap reficon-H -background black -foreground "#00ff00" \
3573 -data $rectdata -maskdata $rectmask
3574image create bitmap reficon-R -background black -foreground "#ffddaa" \
3575 -data $rectdata -maskdata $rectmask
3576image create bitmap reficon-o -background black -foreground "#ddddff" \
3577 -data $rectdata -maskdata $rectmask
3578
3579proc init_flist {first} {
3580 global cflist cflist_top difffilestart
3581
3582 $cflist conf -state normal
3583 $cflist delete 0.0 end
3584 if {$first ne {}} {
3585 $cflist insert end $first
3586 set cflist_top 1
3587 $cflist tag add highlight 1.0 "1.0 lineend"
3588 } else {
3589 unset -nocomplain cflist_top
3590 }
3591 $cflist conf -state disabled
3592 set difffilestart {}
3593}
3594
3595proc highlight_tag {f} {
3596 global highlight_paths
3597
3598 foreach p $highlight_paths {
3599 if {[string match $p $f]} {
3600 return "bold"
3601 }
3602 }
3603 return {}
3604}
3605
3606proc highlight_filelist {} {
3607 global cmitmode cflist
3608
3609 $cflist conf -state normal
3610 if {$cmitmode ne "tree"} {
3611 set end [lindex [split [$cflist index end] .] 0]
3612 for {set l 2} {$l < $end} {incr l} {
3613 set line [$cflist get $l.0 "$l.0 lineend"]
3614 if {[highlight_tag $line] ne {}} {
3615 $cflist tag add bold $l.0 "$l.0 lineend"
3616 }
3617 }
3618 } else {
3619 highlight_tree 2 {}
3620 }
3621 $cflist conf -state disabled
3622}
3623
3624proc unhighlight_filelist {} {
3625 global cflist
3626
3627 $cflist conf -state normal
3628 $cflist tag remove bold 1.0 end
3629 $cflist conf -state disabled
3630}
3631
3632proc add_flist {fl} {
3633 global cflist
3634
3635 $cflist conf -state normal
3636 foreach f $fl {
3637 $cflist insert end "\n"
3638 $cflist insert end $f [highlight_tag $f]
3639 }
3640 $cflist conf -state disabled
3641}
3642
3643proc sel_flist {w x y} {
3644 global ctext difffilestart cflist cflist_top cmitmode
3645
3646 if {$cmitmode eq "tree"} return
3647 if {![info exists cflist_top]} return
3648 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3649 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
3650 $cflist tag add highlight $l.0 "$l.0 lineend"
3651 set cflist_top $l
3652 if {$l == 1} {
3653 $ctext yview 1.0
3654 } else {
3655 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
3656 }
3657 suppress_highlighting_file_for_current_scrollpos
3658}
3659
3660proc pop_flist_menu {w X Y x y} {
3661 global ctext cflist cmitmode flist_menu flist_menu_file
3662 global treediffs diffids
3663
3664 stopfinding
3665 set l [lindex [split [$w index "@$x,$y"] "."] 0]
3666 if {$l <= 1} return
3667 if {$cmitmode eq "tree"} {
3668 set e [linetoelt $l]
3669 if {[string index $e end] eq "/"} return
3670 } else {
3671 set e [lindex $treediffs($diffids) [expr {$l-2}]]
3672 }
3673 set flist_menu_file $e
3674 set xdiffstate "normal"
3675 if {$cmitmode eq "tree"} {
3676 set xdiffstate "disabled"
3677 }
3678 # Disable "External diff" item in tree mode
3679 $flist_menu entryconf 2 -state $xdiffstate
3680 tk_popup $flist_menu $X $Y
3681}
3682
3683proc find_ctext_fileinfo {line} {
3684 global ctext_file_names ctext_file_lines
3685
3686 set ok [bsearch $ctext_file_lines $line]
3687 set tline [lindex $ctext_file_lines $ok]
3688
3689 if {$ok >= [llength $ctext_file_lines] || $line < $tline} {
3690 return {}
3691 } else {
3692 return [list [lindex $ctext_file_names $ok] $tline]
3693 }
3694}
3695
3696proc pop_diff_menu {w X Y x y} {
3697 global ctext diff_menu flist_menu_file
3698 global diff_menu_txtpos diff_menu_line
3699 global diff_menu_filebase
3700
3701 set diff_menu_txtpos [split [$w index "@$x,$y"] "."]
3702 set diff_menu_line [lindex $diff_menu_txtpos 0]
3703 # don't pop up the menu on hunk-separator or file-separator lines
3704 if {[lsearch -glob [$ctext tag names $diff_menu_line.0] "*sep"] >= 0} {
3705 return
3706 }
3707 stopfinding
3708 set f [find_ctext_fileinfo $diff_menu_line]
3709 if {$f eq {}} return
3710 set flist_menu_file [lindex $f 0]
3711 set diff_menu_filebase [lindex $f 1]
3712 tk_popup $diff_menu $X $Y
3713}
3714
3715proc flist_hl {only} {
3716 global flist_menu_file findstring gdttype
3717
3718 set x [shellquote $flist_menu_file]
3719 if {$only || $findstring eq {} || $gdttype ne [mc "touching paths:"]} {
3720 set findstring $x
3721 } else {
3722 append findstring " " $x
3723 }
3724 set gdttype [mc "touching paths:"]
3725}
3726
3727proc gitknewtmpdir {} {
3728 global diffnum gitktmpdir gitdir env
3729
3730 if {![info exists gitktmpdir]} {
3731 if {[info exists env(GITK_TMPDIR)]} {
3732 set tmpdir $env(GITK_TMPDIR)
3733 } elseif {[info exists env(TMPDIR)]} {
3734 set tmpdir $env(TMPDIR)
3735 } else {
3736 set tmpdir $gitdir
3737 }
3738 set gitktmpformat [file join $tmpdir ".gitk-tmp.XXXXXX"]
3739 if {[catch {set gitktmpdir [safe_exec [list mktemp -d $gitktmpformat]]}]} {
3740 set gitktmpdir [file join $gitdir [format ".gitk-tmp.%s" [pid]]]
3741 }
3742 if {[catch {file mkdir $gitktmpdir} err]} {
3743 error_popup "[mc "Error creating temporary directory %s:" $gitktmpdir] $err"
3744 unset gitktmpdir
3745 return {}
3746 }
3747 set diffnum 0
3748 }
3749 incr diffnum
3750 set diffdir [file join $gitktmpdir $diffnum]
3751 if {[catch {file mkdir $diffdir} err]} {
3752 error_popup "[mc "Error creating temporary directory %s:" $diffdir] $err"
3753 return {}
3754 }
3755 return $diffdir
3756}
3757
3758proc save_file_from_commit {filename output what} {
3759 global nullfile
3760
3761 if {[catch {safe_exec_redirect [list git show $filename --] [list > $output]} err]} {
3762 if {[string match "fatal: bad revision *" $err]} {
3763 return $nullfile
3764 }
3765 error_popup "[mc "Error getting \"%s\" from %s:" $filename $what] $err"
3766 return {}
3767 }
3768 return $output
3769}
3770
3771proc external_diff_get_one_file {diffid filename diffdir} {
3772 global nullid nullid2 nullfile
3773 global worktree
3774
3775 if {$diffid == $nullid} {
3776 set difffile [file join $worktree $filename]
3777 if {[file exists $difffile]} {
3778 return $difffile
3779 }
3780 return $nullfile
3781 }
3782 if {$diffid == $nullid2} {
3783 set difffile [file join $diffdir "\[index\] [file tail $filename]"]
3784 return [save_file_from_commit :$filename $difffile index]
3785 }
3786 set difffile [file join $diffdir "\[$diffid\] [file tail $filename]"]
3787 return [save_file_from_commit $diffid:$filename $difffile \
3788 "revision $diffid"]
3789}
3790
3791proc external_diff {} {
3792 global nullid nullid2
3793 global flist_menu_file
3794 global diffids
3795 global extdifftool
3796
3797 if {[llength $diffids] == 1} {
3798 # no reference commit given
3799 set diffidto [lindex $diffids 0]
3800 if {$diffidto eq $nullid} {
3801 # diffing working copy with index
3802 set diffidfrom $nullid2
3803 } elseif {$diffidto eq $nullid2} {
3804 # diffing index with HEAD
3805 set diffidfrom "HEAD"
3806 } else {
3807 # use first parent commit
3808 global parentlist selectedline
3809 set diffidfrom [lindex $parentlist $selectedline 0]
3810 }
3811 } else {
3812 set diffidfrom [lindex $diffids 0]
3813 set diffidto [lindex $diffids 1]
3814 }
3815
3816 # make sure that several diffs wont collide
3817 set diffdir [gitknewtmpdir]
3818 if {$diffdir eq {}} return
3819
3820 # gather files to diff
3821 set difffromfile [external_diff_get_one_file $diffidfrom $flist_menu_file $diffdir]
3822 set difftofile [external_diff_get_one_file $diffidto $flist_menu_file $diffdir]
3823
3824 if {$difffromfile ne {} && $difftofile ne {}} {
3825 set cmd [list [shellsplit $extdifftool] $difffromfile $difftofile]
3826 if {[catch {set fl [safe_open_command $cmd]} err]} {
3827 file delete -force $diffdir
3828 error_popup "$extdifftool: [mc "command failed:"] $err"
3829 } else {
3830 fconfigure $fl -blocking 0
3831 filerun $fl [list delete_at_eof $fl $diffdir]
3832 }
3833 }
3834}
3835
3836proc find_hunk_blamespec {base line} {
3837 global ctext
3838
3839 # Find and parse the hunk header
3840 set s_lix [$ctext search -backwards -regexp ^@@ "$line.0 lineend" $base.0]
3841 if {$s_lix eq {}} return
3842
3843 set s_line [$ctext get $s_lix "$s_lix + 1 lines"]
3844 if {![regexp {^@@@*(( -\d+(,\d+)?)+) \+(\d+)(,\d+)? @@} $s_line \
3845 s_line old_specs osz osz1 new_line nsz]} {
3846 return
3847 }
3848
3849 # base lines for the parents
3850 set base_lines [list $new_line]
3851 foreach old_spec [lrange [split $old_specs " "] 1 end] {
3852 if {![regexp -- {-(\d+)(,\d+)?} $old_spec \
3853 old_spec old_line osz]} {
3854 return
3855 }
3856 lappend base_lines $old_line
3857 }
3858
3859 # Now scan the lines to determine offset within the hunk
3860 set max_parent [expr {[llength $base_lines]-2}]
3861 set dline 0
3862 set s_lno [lindex [split $s_lix "."] 0]
3863
3864 # Determine if the line is removed
3865 set chunk [$ctext get $line.0 "$line.1 + $max_parent chars"]
3866 if {[string match {[-+ ]*} $chunk]} {
3867 set removed_idx [string first "-" $chunk]
3868 # Choose a parent index
3869 if {$removed_idx >= 0} {
3870 set parent $removed_idx
3871 } else {
3872 set unchanged_idx [string first " " $chunk]
3873 if {$unchanged_idx >= 0} {
3874 set parent $unchanged_idx
3875 } else {
3876 # blame the current commit
3877 set parent -1
3878 }
3879 }
3880 # then count other lines that belong to it
3881 for {set i $line} {[incr i -1] > $s_lno} {} {
3882 set chunk [$ctext get $i.0 "$i.1 + $max_parent chars"]
3883 # Determine if the line is removed
3884 set removed_idx [string first "-" $chunk]
3885 if {$parent >= 0} {
3886 set code [string index $chunk $parent]
3887 if {$code eq "-" || ($removed_idx < 0 && $code ne "+")} {
3888 incr dline
3889 }
3890 } else {
3891 if {$removed_idx < 0} {
3892 incr dline
3893 }
3894 }
3895 }
3896 incr parent
3897 } else {
3898 set parent 0
3899 }
3900
3901 incr dline [lindex $base_lines $parent]
3902 return [list $parent $dline]
3903}
3904
3905proc external_blame_diff {} {
3906 global currentid cmitmode
3907 global diff_menu_txtpos diff_menu_line
3908 global diff_menu_filebase flist_menu_file
3909
3910 if {$cmitmode eq "tree"} {
3911 set parent_idx 0
3912 set line [expr {$diff_menu_line - $diff_menu_filebase}]
3913 } else {
3914 set hinfo [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
3915 if {$hinfo ne {}} {
3916 set parent_idx [lindex $hinfo 0]
3917 set line [lindex $hinfo 1]
3918 } else {
3919 set parent_idx 0
3920 set line 0
3921 }
3922 }
3923
3924 external_blame $parent_idx $line
3925}
3926
3927# Find the SHA1 ID of the blob for file $fname in the index
3928# at stage 0 or 2
3929proc index_sha1 {fname} {
3930 set f [safe_open_command [list git ls-files -s $fname]]
3931 while {[gets $f line] >= 0} {
3932 set info [lindex [split $line "\t"] 0]
3933 set stage [lindex $info 2]
3934 if {$stage eq "0" || $stage eq "2"} {
3935 close $f
3936 return [lindex $info 1]
3937 }
3938 }
3939 close $f
3940 return {}
3941}
3942
3943# Turn an absolute path into one relative to the current directory
3944proc make_relative {f} {
3945 if {[file pathtype $f] eq "relative"} {
3946 return $f
3947 }
3948 set elts [file split $f]
3949 set here [file split [pwd]]
3950 set ei 0
3951 set hi 0
3952 set res {}
3953 foreach d $here {
3954 if {$ei < $hi || $ei >= [llength $elts] || [lindex $elts $ei] ne $d} {
3955 lappend res ".."
3956 } else {
3957 incr ei
3958 }
3959 incr hi
3960 }
3961 set elts [concat $res [lrange $elts $ei end]]
3962 return [eval file join $elts]
3963}
3964
3965proc external_blame {parent_idx {line {}}} {
3966 global flist_menu_file cdup
3967 global nullid nullid2
3968 global parentlist selectedline currentid
3969
3970 if {$parent_idx > 0} {
3971 set base_commit [lindex $parentlist $selectedline [expr {$parent_idx-1}]]
3972 } else {
3973 set base_commit $currentid
3974 }
3975
3976 if {$base_commit eq {} || $base_commit eq $nullid || $base_commit eq $nullid2} {
3977 error_popup [mc "No such commit"]
3978 return
3979 }
3980
3981 set cmdline [list git gui blame]
3982 if {$line ne {} && $line > 1} {
3983 lappend cmdline "--line=$line"
3984 }
3985 set f [file join $cdup $flist_menu_file]
3986 # Unfortunately it seems git gui blame doesn't like
3987 # being given an absolute path...
3988 set f [make_relative $f]
3989 lappend cmdline $base_commit $f
3990 if {[catch {safe_exec_redirect $cmdline [list &]} err]} {
3991 error_popup "[mc "git gui blame: command failed:"] $err"
3992 }
3993}
3994
3995proc show_line_source {} {
3996 global cmitmode currentid parents curview blamestuff blameinst
3997 global diff_menu_line diff_menu_filebase flist_menu_file
3998 global nullid nullid2 gitdir cdup
3999
4000 set from_index {}
4001 if {$cmitmode eq "tree"} {
4002 set id $currentid
4003 set line [expr {$diff_menu_line - $diff_menu_filebase}]
4004 } else {
4005 set h [find_hunk_blamespec $diff_menu_filebase $diff_menu_line]
4006 if {$h eq {}} return
4007 set pi [lindex $h 0]
4008 if {$pi == 0} {
4009 mark_ctext_line $diff_menu_line
4010 return
4011 }
4012 incr pi -1
4013 if {$currentid eq $nullid} {
4014 if {$pi > 0} {
4015 # must be a merge in progress...
4016 if {[catch {
4017 # get the last line from .git/MERGE_HEAD
4018 set f [safe_open_file [file join $gitdir MERGE_HEAD] r]
4019 set id [lindex [split [read $f] "\n"] end-1]
4020 close $f
4021 } err]} {
4022 error_popup [mc "Couldn't read merge head: %s" $err]
4023 return
4024 }
4025 } elseif {$parents($curview,$currentid) eq $nullid2} {
4026 # need to do the blame from the index
4027 if {[catch {
4028 set from_index [index_sha1 $flist_menu_file]
4029 } err]} {
4030 error_popup [mc "Error reading index: %s" $err]
4031 return
4032 }
4033 } else {
4034 set id $parents($curview,$currentid)
4035 }
4036 } else {
4037 set id [lindex $parents($curview,$currentid) $pi]
4038 }
4039 set line [lindex $h 1]
4040 }
4041 set blamefile [file join $cdup $flist_menu_file]
4042 if {$from_index ne {}} {
4043 set blameargs [list \
4044 [list git cat-file blob $from_index] \
4045 [list git blame -p -L$line,+1 --contents - -- $blamefile]]
4046 } else {
4047 set blameargs [list \
4048 [list git blame -p -L$line,+1 $id -- $blamefile]]
4049 }
4050 if {[catch {
4051 set f [safe_open_pipeline $blameargs]
4052 } err]} {
4053 error_popup [mc "Couldn't start git blame: %s" $err]
4054 return
4055 }
4056 nowbusy blaming [mc "Searching"]
4057 fconfigure $f -blocking 0
4058 set i [reg_instance $f]
4059 set blamestuff($i) {}
4060 set blameinst $i
4061 filerun $f [list read_line_source $f $i]
4062}
4063
4064proc stopblaming {} {
4065 global blameinst
4066
4067 if {[info exists blameinst]} {
4068 stop_instance $blameinst
4069 unset blameinst
4070 notbusy blaming
4071 }
4072}
4073
4074proc read_line_source {fd inst} {
4075 global blamestuff curview commfd blameinst nullid nullid2
4076 global hashlength
4077
4078 while {[gets $fd line] >= 0} {
4079 lappend blamestuff($inst) $line
4080 }
4081 if {![eof $fd]} {
4082 return 1
4083 }
4084 unset commfd($inst)
4085 unset blameinst
4086 notbusy blaming
4087 fconfigure $fd -blocking 1
4088 if {[catch {close $fd} err]} {
4089 error_popup [mc "Error running git blame: %s" $err]
4090 return 0
4091 }
4092
4093 set fname {}
4094 set line [split [lindex $blamestuff($inst) 0] " "]
4095 set id [lindex $line 0]
4096 set lnum [lindex $line 1]
4097 if {[string length $id] == $hashlength && [string is xdigit $id] &&
4098 [string is digit -strict $lnum]} {
4099 # look for "filename" line
4100 foreach l $blamestuff($inst) {
4101 if {[string match "filename *" $l]} {
4102 set fname [string range $l 9 end]
4103 break
4104 }
4105 }
4106 }
4107 if {$fname ne {}} {
4108 # all looks good, select it
4109 if {$id eq $nullid} {
4110 # blame uses all-zeroes to mean not committed,
4111 # which would mean a change in the index
4112 set id $nullid2
4113 }
4114 if {[commitinview $id $curview]} {
4115 selectline [rowofcommit $id] 1 [list $fname $lnum] 1
4116 } else {
4117 error_popup [mc "That line comes from commit %s, \
4118 which is not in this view" [shortids $id]]
4119 }
4120 } else {
4121 puts "oops couldn't parse git blame output"
4122 }
4123 return 0
4124}
4125
4126# delete $dir when we see eof on $f (presumably because the child has exited)
4127proc delete_at_eof {f dir} {
4128 while {[gets $f line] >= 0} {}
4129 if {[eof $f]} {
4130 if {[catch {close $f} err]} {
4131 error_popup "[mc "External diff viewer failed:"] $err"
4132 }
4133 file delete -force $dir
4134 return 0
4135 }
4136 return 1
4137}
4138
4139# Functions for adding and removing shell-type quoting
4140
4141proc shellquote {str} {
4142 if {![string match "*\['\"\\ \t]*" $str]} {
4143 return $str
4144 }
4145 if {![string match "*\['\"\\]*" $str]} {
4146 return "\"$str\""
4147 }
4148 if {![string match "*'*" $str]} {
4149 return "'$str'"
4150 }
4151 return "\"[string map {\" \\\" \\ \\\\} $str]\""
4152}
4153
4154proc shellarglist {l} {
4155 set str {}
4156 foreach a $l {
4157 if {$str ne {}} {
4158 append str " "
4159 }
4160 append str [shellquote $a]
4161 }
4162 return $str
4163}
4164
4165proc shelldequote {str} {
4166 set ret {}
4167 set used -1
4168 while {1} {
4169 incr used
4170 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
4171 append ret [string range $str $used end]
4172 set used [string length $str]
4173 break
4174 }
4175 set first [lindex $first 0]
4176 set ch [string index $str $first]
4177 if {$first > $used} {
4178 append ret [string range $str $used [expr {$first - 1}]]
4179 set used $first
4180 }
4181 if {$ch eq " " || $ch eq "\t"} break
4182 incr used
4183 if {$ch eq "'"} {
4184 set first [string first "'" $str $used]
4185 if {$first < 0} {
4186 error "unmatched single-quote"
4187 }
4188 append ret [string range $str $used [expr {$first - 1}]]
4189 set used $first
4190 continue
4191 }
4192 if {$ch eq "\\"} {
4193 if {$used >= [string length $str]} {
4194 error "trailing backslash"
4195 }
4196 append ret [string index $str $used]
4197 continue
4198 }
4199 # here ch == "\""
4200 while {1} {
4201 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
4202 error "unmatched double-quote"
4203 }
4204 set first [lindex $first 0]
4205 set ch [string index $str $first]
4206 if {$first > $used} {
4207 append ret [string range $str $used [expr {$first - 1}]]
4208 set used $first
4209 }
4210 if {$ch eq "\""} break
4211 incr used
4212 append ret [string index $str $used]
4213 incr used
4214 }
4215 }
4216 return [list $used $ret]
4217}
4218
4219proc shellsplit {str} {
4220 set l {}
4221 while {1} {
4222 set str [string trimleft $str]
4223 if {$str eq {}} break
4224 set dq [shelldequote $str]
4225 set n [lindex $dq 0]
4226 set word [lindex $dq 1]
4227 set str [string range $str $n end]
4228 lappend l $word
4229 }
4230 return $l
4231}
4232
4233proc set_window_title {} {
4234 global appname curview viewname vrevs
4235 set rev [mc "All files"]
4236 if {$curview ne 0} {
4237 if {$viewname($curview) eq [mc "Command line"]} {
4238 set rev [string map {"--gitk-symmetric-diff-marker" "--merge"} $vrevs($curview)]
4239 } else {
4240 set rev $viewname($curview)
4241 }
4242 }
4243 wm title . "[reponame]: $rev - $appname"
4244}
4245
4246# Code to implement multiple views
4247
4248proc newview {ishighlight} {
4249 global nextviewnum newviewname newishighlight
4250 global revtreeargs viewargscmd newviewopts curview
4251
4252 set newishighlight $ishighlight
4253 set top .gitkview
4254 if {[winfo exists $top]} {
4255 raise $top
4256 return
4257 }
4258 decode_view_opts $nextviewnum $revtreeargs
4259 set newviewname($nextviewnum) "[mc "View"] $nextviewnum"
4260 set newviewopts($nextviewnum,perm) 0
4261 set newviewopts($nextviewnum,cmd) $viewargscmd($curview)
4262 vieweditor $top $nextviewnum [mc "Gitk view definition"]
4263}
4264
4265set known_view_options {
4266 {perm b . {} {mc "Remember this view"}}
4267 {reflabel l + {} {mc "References (space separated list):"}}
4268 {refs t15 .. {} {mc "Branches & tags:"}}
4269 {allrefs b *. "--all" {mc "All refs"}}
4270 {branches b . "--branches" {mc "All (local) branches"}}
4271 {tags b . "--tags" {mc "All tags"}}
4272 {remotes b . "--remotes" {mc "All remote-tracking branches"}}
4273 {commitlbl l + {} {mc "Commit Info (regular expressions):"}}
4274 {author t15 .. "--author=*" {mc "Author:"}}
4275 {committer t15 . "--committer=*" {mc "Committer:"}}
4276 {loginfo t15 .. "--grep=*" {mc "Commit Message:"}}
4277 {allmatch b .. "--all-match" {mc "Matches all Commit Info criteria"}}
4278 {igrep b .. "--invert-grep" {mc "Matches no Commit Info criteria"}}
4279 {changes_l l + {} {mc "Changes to Files:"}}
4280 {pickaxe_s r0 . {} {mc "Fixed String"}}
4281 {pickaxe_t r1 . "--pickaxe-regex" {mc "Regular Expression"}}
4282 {pickaxe t15 .. "-S*" {mc "Search string:"}}
4283 {datelabel l + {} {mc "Commit Dates (\"2 weeks ago\", \"2009-03-17 15:27:38\", \"March 17, 2009 15:27:38\"):"}}
4284 {since t15 .. {"--since=*" "--after=*"} {mc "Since:"}}
4285 {until t15 . {"--until=*" "--before=*"} {mc "Until:"}}
4286 {limit_lbl l + {} {mc "Limit and/or skip a number of revisions (positive integer):"}}
4287 {limit t10 *. "--max-count=*" {mc "Number to show:"}}
4288 {skip t10 . "--skip=*" {mc "Number to skip:"}}
4289 {misc_lbl l + {} {mc "Miscellaneous options:"}}
4290 {dorder b *. {"--date-order" "-d"} {mc "Strictly sort by date"}}
4291 {lright b . "--left-right" {mc "Mark branch sides"}}
4292 {first b . "--first-parent" {mc "Limit to first parent"}}
4293 {smplhst b . "--simplify-by-decoration" {mc "Simple history"}}
4294 {args t50 *. {} {mc "Additional arguments to git log:"}}
4295 {allpaths path + {} {mc "Enter files and directories to include, one per line:"}}
4296 {cmd t50= + {} {mc "Command to generate more commits to include:"}}
4297 }
4298
4299# Convert $newviewopts($n, ...) into args for git log.
4300proc encode_view_opts {n} {
4301 global known_view_options newviewopts
4302
4303 set rargs [list]
4304 foreach opt $known_view_options {
4305 set patterns [lindex $opt 3]
4306 if {$patterns eq {}} continue
4307 set pattern [lindex $patterns 0]
4308
4309 if {[lindex $opt 1] eq "b"} {
4310 set val $newviewopts($n,[lindex $opt 0])
4311 if {$val} {
4312 lappend rargs $pattern
4313 }
4314 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] type value]} {
4315 regexp {^(.*_)} [lindex $opt 0] uselessvar button_id
4316 set val $newviewopts($n,$button_id)
4317 if {$val eq $value} {
4318 lappend rargs $pattern
4319 }
4320 } else {
4321 set val $newviewopts($n,[lindex $opt 0])
4322 set val [string trim $val]
4323 if {$val ne {}} {
4324 set pfix [string range $pattern 0 end-1]
4325 lappend rargs $pfix$val
4326 }
4327 }
4328 }
4329 set rargs [concat $rargs [shellsplit $newviewopts($n,refs)]]
4330 return [concat $rargs [shellsplit $newviewopts($n,args)]]
4331}
4332
4333# Fill $newviewopts($n, ...) based on args for git log.
4334proc decode_view_opts {n view_args} {
4335 global known_view_options newviewopts
4336
4337 foreach opt $known_view_options {
4338 set id [lindex $opt 0]
4339 if {[lindex $opt 1] eq "b"} {
4340 # Checkboxes
4341 set val 0
4342 } elseif {[regexp {^r(\d+)$} [lindex $opt 1]]} {
4343 # Radiobuttons
4344 regexp {^(.*_)} $id uselessvar id
4345 set val 0
4346 } else {
4347 # Text fields
4348 set val {}
4349 }
4350 set newviewopts($n,$id) $val
4351 }
4352 set oargs [list]
4353 set refargs [list]
4354 foreach arg $view_args {
4355 if {[regexp -- {^-([0-9]+)$} $arg arg cnt]
4356 && ![info exists found(limit)]} {
4357 set newviewopts($n,limit) $cnt
4358 set found(limit) 1
4359 continue
4360 }
4361 catch { unset val }
4362 foreach opt $known_view_options {
4363 set id [lindex $opt 0]
4364 if {[info exists found($id)]} continue
4365 foreach pattern [lindex $opt 3] {
4366 if {![string match $pattern $arg]} continue
4367 if {[lindex $opt 1] eq "b"} {
4368 # Check buttons
4369 set val 1
4370 } elseif {[regexp {^r(\d+)$} [lindex $opt 1] match num]} {
4371 # Radio buttons
4372 regexp {^(.*_)} $id uselessvar id
4373 set val $num
4374 } else {
4375 # Text input fields
4376 set size [string length $pattern]
4377 set val [string range $arg [expr {$size-1}] end]
4378 }
4379 set newviewopts($n,$id) $val
4380 set found($id) 1
4381 break
4382 }
4383 if {[info exists val]} break
4384 }
4385 if {[info exists val]} continue
4386 if {[regexp {^-} $arg]} {
4387 lappend oargs $arg
4388 } else {
4389 lappend refargs $arg
4390 }
4391 }
4392 set newviewopts($n,refs) [shellarglist $refargs]
4393 set newviewopts($n,args) [shellarglist $oargs]
4394}
4395
4396proc edit_or_newview {} {
4397 global curview
4398
4399 if {$curview > 0} {
4400 editview
4401 } else {
4402 newview 0
4403 }
4404}
4405
4406proc editview {} {
4407 global curview
4408 global viewname viewperm newviewname newviewopts
4409 global viewargs viewargscmd
4410
4411 set top .gitkvedit-$curview
4412 if {[winfo exists $top]} {
4413 raise $top
4414 return
4415 }
4416 decode_view_opts $curview $viewargs($curview)
4417 set newviewname($curview) $viewname($curview)
4418 set newviewopts($curview,perm) $viewperm($curview)
4419 set newviewopts($curview,cmd) $viewargscmd($curview)
4420 vieweditor $top $curview "[mc "Gitk: edit view"] $viewname($curview)"
4421}
4422
4423proc vieweditor {top n title} {
4424 global newviewname newviewopts viewfiles bgcolor
4425 global known_view_options
4426
4427 ttk_toplevel $top
4428 wm title $top [concat $title [mc "-- criteria for selecting revisions"]]
4429 make_transient $top .
4430
4431 # View name
4432 ttk::frame $top.nfr
4433 ttk::label $top.nl -text [mc "View Name"]
4434 ttk::entry $top.name -width 20 -textvariable newviewname($n)
4435 pack $top.nfr -in $top -fill x -pady 5 -padx 3
4436 pack $top.nl -in $top.nfr -side left -padx {0 5}
4437 pack $top.name -in $top.nfr -side left -padx {0 25}
4438
4439 # View options
4440 set cframe $top.nfr
4441 set cexpand 0
4442 set cnt 0
4443 foreach opt $known_view_options {
4444 set id [lindex $opt 0]
4445 set type [lindex $opt 1]
4446 set flags [lindex $opt 2]
4447 set title [eval [lindex $opt 4]]
4448 set lxpad 0
4449
4450 if {$flags eq "+" || $flags eq "*"} {
4451 set cframe $top.fr$cnt
4452 incr cnt
4453 ttk::frame $cframe
4454 pack $cframe -in $top -fill x -pady 3 -padx 3
4455 set cexpand [expr {$flags eq "*"}]
4456 } elseif {$flags eq ".." || $flags eq "*."} {
4457 set cframe $top.fr$cnt
4458 incr cnt
4459 ttk::frame $cframe
4460 pack $cframe -in $top -fill x -pady 3 -padx [list 15 3]
4461 set cexpand [expr {$flags eq "*."}]
4462 } else {
4463 set lxpad 5
4464 }
4465
4466 if {$type eq "l"} {
4467 ttk::label $cframe.l_$id -text $title
4468 pack $cframe.l_$id -in $cframe -side left -pady [list 3 0] -anchor w
4469 } elseif {$type eq "b"} {
4470 ttk::checkbutton $cframe.c_$id -text $title -variable newviewopts($n,$id)
4471 pack $cframe.c_$id -in $cframe -side left \
4472 -padx [list $lxpad 0] -expand $cexpand -anchor w
4473 } elseif {[regexp {^r(\d+)$} $type type sz]} {
4474 regexp {^(.*_)} $id uselessvar button_id
4475 ttk::radiobutton $cframe.c_$id -text $title -variable newviewopts($n,$button_id) -value $sz
4476 pack $cframe.c_$id -in $cframe -side left \
4477 -padx [list $lxpad 0] -expand $cexpand -anchor w
4478 } elseif {[regexp {^t(\d+)$} $type type sz]} {
4479 ttk::label $cframe.l_$id -text $title
4480 ttk::entry $cframe.e_$id -width $sz -background $bgcolor \
4481 -textvariable newviewopts($n,$id)
4482 pack $cframe.l_$id -in $cframe -side left -padx [list $lxpad 0]
4483 pack $cframe.e_$id -in $cframe -side left -expand 1 -fill x
4484 } elseif {[regexp {^t(\d+)=$} $type type sz]} {
4485 ttk::label $cframe.l_$id -text $title
4486 ttk::entry $cframe.e_$id -width $sz -background $bgcolor \
4487 -textvariable newviewopts($n,$id)
4488 pack $cframe.l_$id -in $cframe -side top -pady [list 3 0] -anchor w
4489 pack $cframe.e_$id -in $cframe -side top -fill x
4490 } elseif {$type eq "path"} {
4491 ttk::label $top.l -text $title
4492 pack $top.l -in $top -side top -pady [list 3 0] -anchor w -padx 3
4493 text $top.t -width 40 -height 5 -background $bgcolor
4494 if {[info exists viewfiles($n)]} {
4495 foreach f $viewfiles($n) {
4496 $top.t insert end $f
4497 $top.t insert end "\n"
4498 }
4499 $top.t delete {end - 1c} end
4500 $top.t mark set insert 0.0
4501 }
4502 pack $top.t -in $top -side top -pady [list 0 5] -fill both -expand 1 -padx 3
4503 }
4504 }
4505
4506 ttk::frame $top.buts
4507 ttk::button $top.buts.ok -text [mc "OK"] -command [list newviewok $top $n]
4508 ttk::button $top.buts.apply -text [mc "Apply (F5)"] -command [list newviewok $top $n 1]
4509 ttk::button $top.buts.can -text [mc "Cancel"] -command [list destroy $top]
4510 bind $top <Control-Return> [list newviewok $top $n]
4511 bind $top <F5> [list newviewok $top $n 1]
4512 bind $top <Escape> [list destroy $top]
4513 grid $top.buts.ok $top.buts.apply $top.buts.can
4514 grid columnconfigure $top.buts 0 -weight 1 -uniform a
4515 grid columnconfigure $top.buts 1 -weight 1 -uniform a
4516 grid columnconfigure $top.buts 2 -weight 1 -uniform a
4517 pack $top.buts -in $top -side top -fill x
4518 focus $top.t
4519}
4520
4521proc doviewmenu {m first cmd op argv} {
4522 set nmenu [$m index end]
4523 for {set i $first} {$i <= $nmenu} {incr i} {
4524 if {[$m entrycget $i -command] eq $cmd} {
4525 eval $m $op $i $argv
4526 break
4527 }
4528 }
4529}
4530
4531proc allviewmenus {n op args} {
4532 # global viewhlmenu
4533
4534 doviewmenu .bar.view 5 [list showview $n] $op $args
4535 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
4536}
4537
4538proc newviewok {top n {apply 0}} {
4539 global nextviewnum newviewperm newviewname newishighlight
4540 global viewname viewfiles viewperm viewchanged selectedview curview
4541 global viewargs viewargscmd newviewopts viewhlmenu
4542
4543 if {[catch {
4544 set newargs [encode_view_opts $n]
4545 } err]} {
4546 error_popup "[mc "Error in commit selection arguments:"] $err" $top
4547 return
4548 }
4549 set files {}
4550 foreach f [split [$top.t get 0.0 end] "\n"] {
4551 set ft [string trim $f]
4552 if {$ft ne {}} {
4553 lappend files $ft
4554 }
4555 }
4556 if {![info exists viewfiles($n)]} {
4557 # creating a new view
4558 incr nextviewnum
4559 set viewname($n) $newviewname($n)
4560 set viewperm($n) $newviewopts($n,perm)
4561 set viewchanged($n) 1
4562 set viewfiles($n) $files
4563 set viewargs($n) $newargs
4564 set viewargscmd($n) $newviewopts($n,cmd)
4565 addviewmenu $n
4566 if {!$newishighlight} {
4567 run showview $n
4568 } else {
4569 run addvhighlight $n
4570 }
4571 } else {
4572 # editing an existing view
4573 set viewperm($n) $newviewopts($n,perm)
4574 set viewchanged($n) 1
4575 if {$newviewname($n) ne $viewname($n)} {
4576 set viewname($n) $newviewname($n)
4577 doviewmenu .bar.view 5 [list showview $n] \
4578 entryconf [list -label $viewname($n)]
4579 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
4580 # entryconf [list -label $viewname($n) -value $viewname($n)]
4581 }
4582 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n) || \
4583 $newviewopts($n,cmd) ne $viewargscmd($n)} {
4584 set viewfiles($n) $files
4585 set viewargs($n) $newargs
4586 set viewargscmd($n) $newviewopts($n,cmd)
4587 if {$curview == $n} {
4588 run reloadcommits
4589 }
4590 }
4591 }
4592 if {$apply} return
4593 catch {destroy $top}
4594}
4595
4596proc delview {} {
4597 global curview viewperm hlview selectedhlview viewchanged
4598
4599 if {$curview == 0} return
4600 if {[info exists hlview] && $hlview == $curview} {
4601 set selectedhlview [mc "None"]
4602 unset hlview
4603 }
4604 allviewmenus $curview delete
4605 set viewperm($curview) 0
4606 set viewchanged($curview) 1
4607 showview 0
4608}
4609
4610proc addviewmenu {n} {
4611 global viewname viewhlmenu
4612
4613 .bar.view add radiobutton -label $viewname($n) \
4614 -command [list showview $n] -variable selectedview -value $n
4615 #$viewhlmenu add radiobutton -label $viewname($n) \
4616 # -command [list addvhighlight $n] -variable selectedhlview
4617}
4618
4619proc showview {n} {
4620 global curview cached_commitrow ordertok
4621 global displayorder parentlist rowidlist rowisopt rowfinal
4622 global colormap rowtextx nextcolor canvxmax
4623 global numcommits viewcomplete
4624 global selectedline currentid canv canvy0
4625 global treediffs
4626 global pending_select mainheadid
4627 global commitidx
4628 global selectedview
4629 global hlview selectedhlview commitinterest
4630
4631 if {$n == $curview} return
4632 set selid {}
4633 set ymax [lindex [$canv cget -scrollregion] 3]
4634 set span [$canv yview]
4635 set ytop [expr {[lindex $span 0] * $ymax}]
4636 set ybot [expr {[lindex $span 1] * $ymax}]
4637 set yscreen [expr {($ybot - $ytop) / 2}]
4638 if {$selectedline ne {}} {
4639 set selid $currentid
4640 set y [yc $selectedline]
4641 if {$ytop < $y && $y < $ybot} {
4642 set yscreen [expr {$y - $ytop}]
4643 }
4644 } elseif {[info exists pending_select]} {
4645 set selid $pending_select
4646 unset pending_select
4647 }
4648 unselectline
4649 normalline
4650 unset -nocomplain treediffs
4651 clear_display
4652 if {[info exists hlview] && $hlview == $n} {
4653 unset hlview
4654 set selectedhlview [mc "None"]
4655 }
4656 unset -nocomplain commitinterest
4657 unset -nocomplain cached_commitrow
4658 unset -nocomplain ordertok
4659
4660 set curview $n
4661 set selectedview $n
4662 .bar.view entryconf [mca "&Edit view..."] -state [expr {$n == 0? "disabled": "normal"}]
4663 .bar.view entryconf [mca "&Delete view"] -state [expr {$n == 0? "disabled": "normal"}]
4664
4665 run refill_reflist
4666 if {![info exists viewcomplete($n)]} {
4667 getcommits $selid
4668 return
4669 }
4670
4671 set displayorder {}
4672 set parentlist {}
4673 set rowidlist {}
4674 set rowisopt {}
4675 set rowfinal {}
4676 set numcommits $commitidx($n)
4677
4678 unset -nocomplain colormap
4679 unset -nocomplain rowtextx
4680 set nextcolor 0
4681 set canvxmax [$canv cget -width]
4682 set curview $n
4683 set row 0
4684 setcanvscroll
4685 set yf 0
4686 set row {}
4687 if {$selid ne {} && [commitinview $selid $n]} {
4688 set row [rowofcommit $selid]
4689 # try to get the selected row in the same position on the screen
4690 set ymax [lindex [$canv cget -scrollregion] 3]
4691 set ytop [expr {[yc $row] - $yscreen}]
4692 if {$ytop < 0} {
4693 set ytop 0
4694 }
4695 set yf [expr {$ytop * 1.0 / $ymax}]
4696 }
4697 allcanvs yview moveto $yf
4698 drawvisible
4699 if {$row ne {}} {
4700 selectline $row 0
4701 } elseif {!$viewcomplete($n)} {
4702 reset_pending_select $selid
4703 } else {
4704 reset_pending_select {}
4705
4706 if {[commitinview $pending_select $curview]} {
4707 selectline [rowofcommit $pending_select] 1
4708 } else {
4709 set row [first_real_row]
4710 if {$row < $numcommits} {
4711 selectline $row 0
4712 }
4713 }
4714 }
4715 if {!$viewcomplete($n)} {
4716 if {$numcommits == 0} {
4717 show_status [mc "Reading commits..."]
4718 }
4719 } elseif {$numcommits == 0} {
4720 show_status [mc "No commits selected"]
4721 }
4722 set_window_title
4723}
4724
4725# Stuff relating to the highlighting facility
4726
4727proc ishighlighted {id} {
4728 global vhighlights fhighlights nhighlights rhighlights
4729
4730 if {[info exists nhighlights($id)] && $nhighlights($id) > 0} {
4731 return $nhighlights($id)
4732 }
4733 if {[info exists vhighlights($id)] && $vhighlights($id) > 0} {
4734 return $vhighlights($id)
4735 }
4736 if {[info exists fhighlights($id)] && $fhighlights($id) > 0} {
4737 return $fhighlights($id)
4738 }
4739 if {[info exists rhighlights($id)] && $rhighlights($id) > 0} {
4740 return $rhighlights($id)
4741 }
4742 return 0
4743}
4744
4745proc bolden {id font} {
4746 global canv linehtag currentid boldids need_redisplay markedid
4747
4748 # need_redisplay = 1 means the display is stale and about to be redrawn
4749 if {$need_redisplay} return
4750 lappend boldids $id
4751 $canv itemconf $linehtag($id) -font $font
4752 if {[info exists currentid] && $id eq $currentid} {
4753 $canv delete secsel
4754 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
4755 -outline {{}} -tags secsel \
4756 -fill [$canv cget -selectbackground]]
4757 $canv lower $t
4758 }
4759 if {[info exists markedid] && $id eq $markedid} {
4760 make_idmark $id
4761 }
4762}
4763
4764proc bolden_name {id font} {
4765 global canv2 linentag currentid boldnameids need_redisplay
4766
4767 if {$need_redisplay} return
4768 lappend boldnameids $id
4769 $canv2 itemconf $linentag($id) -font $font
4770 if {[info exists currentid] && $id eq $currentid} {
4771 $canv2 delete secsel
4772 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] \
4773 -outline {{}} -tags secsel \
4774 -fill [$canv2 cget -selectbackground]]
4775 $canv2 lower $t
4776 }
4777}
4778
4779proc unbolden {} {
4780 global boldids
4781
4782 set stillbold {}
4783 foreach id $boldids {
4784 if {![ishighlighted $id]} {
4785 bolden $id mainfont
4786 } else {
4787 lappend stillbold $id
4788 }
4789 }
4790 set boldids $stillbold
4791}
4792
4793proc addvhighlight {n} {
4794 global hlview viewcomplete curview vhl_done commitidx
4795
4796 if {[info exists hlview]} {
4797 delvhighlight
4798 }
4799 set hlview $n
4800 if {$n != $curview && ![info exists viewcomplete($n)]} {
4801 start_rev_list $n
4802 }
4803 set vhl_done $commitidx($hlview)
4804 if {$vhl_done > 0} {
4805 drawvisible
4806 }
4807}
4808
4809proc delvhighlight {} {
4810 global hlview vhighlights
4811
4812 if {![info exists hlview]} return
4813 unset hlview
4814 unset -nocomplain vhighlights
4815 unbolden
4816}
4817
4818proc vhighlightmore {} {
4819 global hlview vhl_done commitidx vhighlights curview
4820
4821 set max $commitidx($hlview)
4822 set vr [visiblerows]
4823 set r0 [lindex $vr 0]
4824 set r1 [lindex $vr 1]
4825 for {set i $vhl_done} {$i < $max} {incr i} {
4826 set id [commitonrow $i $hlview]
4827 if {[commitinview $id $curview]} {
4828 set row [rowofcommit $id]
4829 if {$r0 <= $row && $row <= $r1} {
4830 if {![highlighted $row]} {
4831 bolden $id mainfontbold
4832 }
4833 set vhighlights($id) 1
4834 }
4835 }
4836 }
4837 set vhl_done $max
4838 return 0
4839}
4840
4841proc askvhighlight {row id} {
4842 global hlview vhighlights iddrawn
4843
4844 if {[commitinview $id $hlview]} {
4845 if {[info exists iddrawn($id)] && ![ishighlighted $id]} {
4846 bolden $id mainfontbold
4847 }
4848 set vhighlights($id) 1
4849 } else {
4850 set vhighlights($id) 0
4851 }
4852}
4853
4854proc hfiles_change {} {
4855 global highlight_files filehighlight fhighlights fh_serial
4856 global highlight_paths
4857
4858 if {[info exists filehighlight]} {
4859 # delete previous highlights
4860 catch {close $filehighlight}
4861 unset filehighlight
4862 unset -nocomplain fhighlights
4863 unbolden
4864 unhighlight_filelist
4865 }
4866 set highlight_paths {}
4867 after cancel do_file_hl $fh_serial
4868 incr fh_serial
4869 if {$highlight_files ne {}} {
4870 after 300 do_file_hl $fh_serial
4871 }
4872}
4873
4874proc gdttype_change {name ix op} {
4875 global gdttype highlight_files findstring findpattern
4876
4877 stopfinding
4878 if {$findstring ne {}} {
4879 if {$gdttype eq [mc "containing:"]} {
4880 if {$highlight_files ne {}} {
4881 set highlight_files {}
4882 hfiles_change
4883 }
4884 findcom_change
4885 } else {
4886 if {$findpattern ne {}} {
4887 set findpattern {}
4888 findcom_change
4889 }
4890 set highlight_files $findstring
4891 hfiles_change
4892 }
4893 drawvisible
4894 }
4895 # enable/disable findtype/findloc menus too
4896}
4897
4898proc find_change {name ix op} {
4899 global gdttype findstring highlight_files
4900
4901 stopfinding
4902 if {$gdttype eq [mc "containing:"]} {
4903 findcom_change
4904 } else {
4905 if {$highlight_files ne $findstring} {
4906 set highlight_files $findstring
4907 hfiles_change
4908 }
4909 }
4910 drawvisible
4911}
4912
4913proc findcom_change args {
4914 global nhighlights boldnameids
4915 global findpattern findtype findstring gdttype
4916
4917 stopfinding
4918 # delete previous highlights, if any
4919 foreach id $boldnameids {
4920 bolden_name $id mainfont
4921 }
4922 set boldnameids {}
4923 unset -nocomplain nhighlights
4924 unbolden
4925 unmarkmatches
4926 if {$gdttype ne [mc "containing:"] || $findstring eq {}} {
4927 set findpattern {}
4928 } elseif {$findtype eq [mc "Regexp"]} {
4929 set findpattern $findstring
4930 } else {
4931 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
4932 $findstring]
4933 set findpattern "*$e*"
4934 }
4935}
4936
4937proc makepatterns {l} {
4938 set ret {}
4939 foreach e $l {
4940 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
4941 if {[string index $ee end] eq "/"} {
4942 lappend ret "$ee*"
4943 } else {
4944 lappend ret $ee
4945 lappend ret "$ee/*"
4946 }
4947 }
4948 return $ret
4949}
4950
4951proc do_file_hl {serial} {
4952 global highlight_files filehighlight highlight_paths gdttype fhl_list
4953 global cdup findtype
4954
4955 if {$gdttype eq [mc "touching paths:"]} {
4956 # If "exact" match then convert backslashes to forward slashes.
4957 # Most useful to support Windows-flavoured file paths.
4958 if {$findtype eq [mc "Exact"]} {
4959 set highlight_files [string map {"\\" "/"} $highlight_files]
4960 }
4961 if {[catch {set paths [shellsplit $highlight_files]}]} return
4962 set highlight_paths [makepatterns $paths]
4963 highlight_filelist
4964 set relative_paths {}
4965 foreach path $paths {
4966 lappend relative_paths [file join $cdup $path]
4967 }
4968 set gdtargs [concat -- $relative_paths]
4969 } elseif {$gdttype eq [mc "adding/removing string:"]} {
4970 set gdtargs [list "-S$highlight_files"]
4971 } elseif {$gdttype eq [mc "changing lines matching:"]} {
4972 set gdtargs [list "-G$highlight_files"]
4973 } else {
4974 # must be "containing:", i.e. we're searching commit info
4975 return
4976 }
4977 set cmd [concat git diff-tree -r -s --stdin $gdtargs]
4978 set filehighlight [safe_open_command_rw $cmd]
4979 fconfigure $filehighlight -blocking 0
4980 filerun $filehighlight readfhighlight
4981 set fhl_list {}
4982 drawvisible
4983 flushhighlights
4984}
4985
4986proc flushhighlights {} {
4987 global filehighlight fhl_list
4988
4989 if {[info exists filehighlight]} {
4990 lappend fhl_list {}
4991 puts $filehighlight ""
4992 flush $filehighlight
4993 }
4994}
4995
4996proc askfilehighlight {row id} {
4997 global filehighlight fhighlights fhl_list
4998
4999 lappend fhl_list $id
5000 set fhighlights($id) -1
5001 puts $filehighlight $id
5002}
5003
5004proc readfhighlight {} {
5005 global filehighlight fhighlights curview iddrawn
5006 global fhl_list find_dirn
5007
5008 if {![info exists filehighlight]} {
5009 return 0
5010 }
5011 set nr 0
5012 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
5013 set line [string trim $line]
5014 set i [lsearch -exact $fhl_list $line]
5015 if {$i < 0} continue
5016 for {set j 0} {$j < $i} {incr j} {
5017 set id [lindex $fhl_list $j]
5018 set fhighlights($id) 0
5019 }
5020 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
5021 if {$line eq {}} continue
5022 if {![commitinview $line $curview]} continue
5023 if {[info exists iddrawn($line)] && ![ishighlighted $line]} {
5024 bolden $line mainfontbold
5025 }
5026 set fhighlights($line) 1
5027 }
5028 if {[eof $filehighlight]} {
5029 # strange...
5030 puts "oops, git diff-tree died"
5031 catch {close $filehighlight}
5032 unset filehighlight
5033 return 0
5034 }
5035 if {[info exists find_dirn]} {
5036 run findmore
5037 }
5038 return 1
5039}
5040
5041proc doesmatch {f} {
5042 global findtype findpattern
5043
5044 if {$findtype eq [mc "Regexp"]} {
5045 return [regexp $findpattern $f]
5046 } elseif {$findtype eq [mc "IgnCase"]} {
5047 return [string match -nocase $findpattern $f]
5048 } else {
5049 return [string match $findpattern $f]
5050 }
5051}
5052
5053proc askfindhighlight {row id} {
5054 global nhighlights commitinfo iddrawn
5055 global findloc
5056 global markingmatches
5057
5058 if {![info exists commitinfo($id)]} {
5059 getcommit $id
5060 }
5061 set info $commitinfo($id)
5062 set isbold 0
5063 set fldtypes [list [mc Headline] [mc Author] "" [mc Committer] "" [mc Comments]]
5064 foreach f $info ty $fldtypes {
5065 if {$ty eq ""} continue
5066 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
5067 [doesmatch $f]} {
5068 if {$ty eq [mc "Author"]} {
5069 set isbold 2
5070 break
5071 }
5072 set isbold 1
5073 }
5074 }
5075 if {$isbold && [info exists iddrawn($id)]} {
5076 if {![ishighlighted $id]} {
5077 bolden $id mainfontbold
5078 if {$isbold > 1} {
5079 bolden_name $id mainfontbold
5080 }
5081 }
5082 if {$markingmatches} {
5083 markrowmatches $row $id
5084 }
5085 }
5086 set nhighlights($id) $isbold
5087}
5088
5089proc markrowmatches {row id} {
5090 global canv canv2 linehtag linentag commitinfo findloc
5091
5092 set headline [lindex $commitinfo($id) 0]
5093 set author [lindex $commitinfo($id) 1]
5094 $canv delete match$row
5095 $canv2 delete match$row
5096 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Headline"]} {
5097 set m [findmatches $headline]
5098 if {$m ne {}} {
5099 markmatches $canv $row $headline $linehtag($id) $m \
5100 [$canv itemcget $linehtag($id) -font] $row
5101 }
5102 }
5103 if {$findloc eq [mc "All fields"] || $findloc eq [mc "Author"]} {
5104 set m [findmatches $author]
5105 if {$m ne {}} {
5106 markmatches $canv2 $row $author $linentag($id) $m \
5107 [$canv2 itemcget $linentag($id) -font] $row
5108 }
5109 }
5110}
5111
5112proc vrel_change {name ix op} {
5113 global highlight_related
5114
5115 rhighlight_none
5116 if {$highlight_related ne [mc "None"]} {
5117 run drawvisible
5118 }
5119}
5120
5121# prepare for testing whether commits are descendents or ancestors of a
5122proc rhighlight_sel {a} {
5123 global descendent desc_todo ancestor anc_todo
5124 global highlight_related
5125
5126 unset -nocomplain descendent
5127 set desc_todo [list $a]
5128 unset -nocomplain ancestor
5129 set anc_todo [list $a]
5130 if {$highlight_related ne [mc "None"]} {
5131 rhighlight_none
5132 run drawvisible
5133 }
5134}
5135
5136proc rhighlight_none {} {
5137 global rhighlights
5138
5139 unset -nocomplain rhighlights
5140 unbolden
5141}
5142
5143proc is_descendent {a} {
5144 global curview children descendent desc_todo
5145
5146 set v $curview
5147 set la [rowofcommit $a]
5148 set todo $desc_todo
5149 set leftover {}
5150 set done 0
5151 for {set i 0} {$i < [llength $todo]} {incr i} {
5152 set do [lindex $todo $i]
5153 if {[rowofcommit $do] < $la} {
5154 lappend leftover $do
5155 continue
5156 }
5157 foreach nk $children($v,$do) {
5158 if {![info exists descendent($nk)]} {
5159 set descendent($nk) 1
5160 lappend todo $nk
5161 if {$nk eq $a} {
5162 set done 1
5163 }
5164 }
5165 }
5166 if {$done} {
5167 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5168 return
5169 }
5170 }
5171 set descendent($a) 0
5172 set desc_todo $leftover
5173}
5174
5175proc is_ancestor {a} {
5176 global curview parents ancestor anc_todo
5177
5178 set v $curview
5179 set la [rowofcommit $a]
5180 set todo $anc_todo
5181 set leftover {}
5182 set done 0
5183 for {set i 0} {$i < [llength $todo]} {incr i} {
5184 set do [lindex $todo $i]
5185 if {![commitinview $do $v] || [rowofcommit $do] > $la} {
5186 lappend leftover $do
5187 continue
5188 }
5189 foreach np $parents($v,$do) {
5190 if {![info exists ancestor($np)]} {
5191 set ancestor($np) 1
5192 lappend todo $np
5193 if {$np eq $a} {
5194 set done 1
5195 }
5196 }
5197 }
5198 if {$done} {
5199 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
5200 return
5201 }
5202 }
5203 set ancestor($a) 0
5204 set anc_todo $leftover
5205}
5206
5207proc askrelhighlight {row id} {
5208 global descendent highlight_related iddrawn rhighlights
5209 global selectedline ancestor
5210
5211 if {$selectedline eq {}} return
5212 set isbold 0
5213 if {$highlight_related eq [mc "Descendant"] ||
5214 $highlight_related eq [mc "Not descendant"]} {
5215 if {![info exists descendent($id)]} {
5216 is_descendent $id
5217 }
5218 if {$descendent($id) == ($highlight_related eq [mc "Descendant"])} {
5219 set isbold 1
5220 }
5221 } elseif {$highlight_related eq [mc "Ancestor"] ||
5222 $highlight_related eq [mc "Not ancestor"]} {
5223 if {![info exists ancestor($id)]} {
5224 is_ancestor $id
5225 }
5226 if {$ancestor($id) == ($highlight_related eq [mc "Ancestor"])} {
5227 set isbold 1
5228 }
5229 }
5230 if {[info exists iddrawn($id)]} {
5231 if {$isbold && ![ishighlighted $id]} {
5232 bolden $id mainfontbold
5233 }
5234 }
5235 set rhighlights($id) $isbold
5236}
5237
5238# Graph layout functions
5239
5240proc shortids {ids} {
5241 global hashlength
5242
5243 set res {}
5244 foreach id $ids {
5245 if {[llength $id] > 1} {
5246 lappend res [shortids $id]
5247 } elseif {[regexp [string map "@@ $hashlength" {^[0-9a-f]{@@}$}] $id]} {
5248 lappend res [string range $id 0 7]
5249 } else {
5250 lappend res $id
5251 }
5252 }
5253 return $res
5254}
5255
5256proc ntimes {n o} {
5257 set ret {}
5258 set o [list $o]
5259 for {set mask 1} {$mask <= $n} {incr mask $mask} {
5260 if {($n & $mask) != 0} {
5261 set ret [concat $ret $o]
5262 }
5263 set o [concat $o $o]
5264 }
5265 return $ret
5266}
5267
5268proc ordertoken {id} {
5269 global ordertok curview varcid varcstart varctok curview parents children
5270 global nullid nullid2
5271
5272 if {[info exists ordertok($id)]} {
5273 return $ordertok($id)
5274 }
5275 set origid $id
5276 set todo {}
5277 while {1} {
5278 if {[info exists varcid($curview,$id)]} {
5279 set a $varcid($curview,$id)
5280 set p [lindex $varcstart($curview) $a]
5281 } else {
5282 set p [lindex $children($curview,$id) 0]
5283 }
5284 if {[info exists ordertok($p)]} {
5285 set tok $ordertok($p)
5286 break
5287 }
5288 set id [first_real_child $curview,$p]
5289 if {$id eq {}} {
5290 # it's a root
5291 set tok [lindex $varctok($curview) $varcid($curview,$p)]
5292 break
5293 }
5294 if {[llength $parents($curview,$id)] == 1} {
5295 lappend todo [list $p {}]
5296 } else {
5297 set j [lsearch -exact $parents($curview,$id) $p]
5298 if {$j < 0} {
5299 puts "oops didn't find [shortids $p] in parents of [shortids $id]"
5300 }
5301 lappend todo [list $p [strrep $j]]
5302 }
5303 }
5304 for {set i [llength $todo]} {[incr i -1] >= 0} {} {
5305 set p [lindex $todo $i 0]
5306 append tok [lindex $todo $i 1]
5307 set ordertok($p) $tok
5308 }
5309 set ordertok($origid) $tok
5310 return $tok
5311}
5312
5313# Work out where id should go in idlist so that order-token
5314# values increase from left to right
5315proc idcol {idlist id {i 0}} {
5316 set t [ordertoken $id]
5317 if {$i < 0} {
5318 set i 0
5319 }
5320 if {$i >= [llength $idlist] || $t < [ordertoken [lindex $idlist $i]]} {
5321 if {$i > [llength $idlist]} {
5322 set i [llength $idlist]
5323 }
5324 while {[incr i -1] >= 0 && $t < [ordertoken [lindex $idlist $i]]} {}
5325 incr i
5326 } else {
5327 if {$t > [ordertoken [lindex $idlist $i]]} {
5328 while {[incr i] < [llength $idlist] &&
5329 $t >= [ordertoken [lindex $idlist $i]]} {}
5330 }
5331 }
5332 return $i
5333}
5334
5335proc initlayout {} {
5336 global rowidlist rowisopt rowfinal displayorder parentlist
5337 global numcommits canvxmax canv
5338 global nextcolor
5339 global colormap rowtextx
5340
5341 set numcommits 0
5342 set displayorder {}
5343 set parentlist {}
5344 set nextcolor 0
5345 set rowidlist {}
5346 set rowisopt {}
5347 set rowfinal {}
5348 set canvxmax [$canv cget -width]
5349 unset -nocomplain colormap
5350 unset -nocomplain rowtextx
5351 setcanvscroll
5352}
5353
5354proc setcanvscroll {} {
5355 global canv canv2 canv3 numcommits linespc canvxmax canvy0
5356 global lastscrollset lastscrollrows
5357
5358 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
5359 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
5360 $canv2 conf -scrollregion [list 0 0 0 $ymax]
5361 $canv3 conf -scrollregion [list 0 0 0 $ymax]
5362 set lastscrollset [clock clicks -milliseconds]
5363 set lastscrollrows $numcommits
5364}
5365
5366proc visiblerows {} {
5367 global canv numcommits linespc
5368
5369 set ymax [lindex [$canv cget -scrollregion] 3]
5370 if {$ymax eq {} || $ymax == 0} return
5371 set f [$canv yview]
5372 set y0 [expr {int([lindex $f 0] * $ymax)}]
5373 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
5374 if {$r0 < 0} {
5375 set r0 0
5376 }
5377 set y1 [expr {int([lindex $f 1] * $ymax)}]
5378 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
5379 if {$r1 >= $numcommits} {
5380 set r1 [expr {$numcommits - 1}]
5381 }
5382 return [list $r0 $r1]
5383}
5384
5385proc layoutmore {} {
5386 global commitidx viewcomplete curview
5387 global numcommits pending_select curview
5388 global lastscrollset lastscrollrows
5389
5390 if {$lastscrollrows < 100 || $viewcomplete($curview) ||
5391 [clock clicks -milliseconds] - $lastscrollset > 500} {
5392 setcanvscroll
5393 }
5394 if {[info exists pending_select] &&
5395 [commitinview $pending_select $curview]} {
5396 update
5397 selectline [rowofcommit $pending_select] 1
5398 }
5399 drawvisible
5400}
5401
5402# With path limiting, we mightn't get the actual HEAD commit,
5403# so ask git rev-list what is the first ancestor of HEAD that
5404# touches a file in the path limit.
5405proc get_viewmainhead {view} {
5406 global viewmainheadid vfilelimit viewinstances mainheadid
5407
5408 catch {
5409 set rfd [safe_open_command [concat git rev-list -1 $mainheadid \
5410 -- $vfilelimit($view)]]
5411 set j [reg_instance $rfd]
5412 lappend viewinstances($view) $j
5413 fconfigure $rfd -blocking 0
5414 filerun $rfd [list getviewhead $rfd $j $view]
5415 set viewmainheadid($curview) {}
5416 }
5417}
5418
5419# git rev-list should give us just 1 line to use as viewmainheadid($view)
5420proc getviewhead {fd inst view} {
5421 global viewmainheadid commfd curview viewinstances showlocalchanges
5422 global hashlength
5423
5424 set id {}
5425 if {[gets $fd line] < 0} {
5426 if {![eof $fd]} {
5427 return 1
5428 }
5429 } elseif {[string length $line] == $hashlength && [string is xdigit $line]} {
5430 set id $line
5431 }
5432 set viewmainheadid($view) $id
5433 close $fd
5434 unset commfd($inst)
5435 set i [lsearch -exact $viewinstances($view) $inst]
5436 if {$i >= 0} {
5437 set viewinstances($view) [lreplace $viewinstances($view) $i $i]
5438 }
5439 if {$showlocalchanges && $id ne {} && $view == $curview} {
5440 doshowlocalchanges
5441 }
5442 return 0
5443}
5444
5445proc doshowlocalchanges {} {
5446 global curview viewmainheadid
5447
5448 if {$viewmainheadid($curview) eq {}} return
5449 if {[commitinview $viewmainheadid($curview) $curview]} {
5450 dodiffindex
5451 } else {
5452 interestedin $viewmainheadid($curview) dodiffindex
5453 }
5454}
5455
5456proc dohidelocalchanges {} {
5457 global nullid nullid2 lserial curview
5458
5459 if {[commitinview $nullid $curview]} {
5460 removefakerow $nullid
5461 }
5462 if {[commitinview $nullid2 $curview]} {
5463 removefakerow $nullid2
5464 }
5465 incr lserial
5466}
5467
5468# spawn off a process to do git diff-index --cached HEAD
5469proc dodiffindex {} {
5470 global lserial showlocalchanges vfilelimit curview
5471 global hasworktree
5472
5473 if {!$showlocalchanges || !$hasworktree} return
5474 incr lserial
5475 set cmd "git diff-index --cached --ignore-submodules=dirty HEAD"
5476 if {$vfilelimit($curview) ne {}} {
5477 set cmd [concat $cmd -- $vfilelimit($curview)]
5478 }
5479 set fd [safe_open_command $cmd]
5480 fconfigure $fd -blocking 0
5481 set i [reg_instance $fd]
5482 filerun $fd [list readdiffindex $fd $lserial $i]
5483}
5484
5485proc readdiffindex {fd serial inst} {
5486 global viewmainheadid nullid nullid2 curview commitinfo commitdata lserial
5487 global vfilelimit
5488
5489 set isdiff 1
5490 if {[gets $fd line] < 0} {
5491 if {![eof $fd]} {
5492 return 1
5493 }
5494 set isdiff 0
5495 }
5496 # we only need to see one line and we don't really care what it says...
5497 stop_instance $inst
5498
5499 if {$serial != $lserial} {
5500 return 0
5501 }
5502
5503 # now see if there are any local changes not checked in to the index
5504 set cmd "git diff-files"
5505 if {$vfilelimit($curview) ne {}} {
5506 set cmd [concat $cmd -- $vfilelimit($curview)]
5507 }
5508 set fd [safe_open_command $cmd]
5509 fconfigure $fd -blocking 0
5510 set i [reg_instance $fd]
5511 filerun $fd [list readdifffiles $fd $serial $i]
5512
5513 if {$isdiff && ![commitinview $nullid2 $curview]} {
5514 # add the line for the changes in the index to the graph
5515 set hl [mc "Local changes checked in to index but not committed"]
5516 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
5517 set commitdata($nullid2) "\n $hl\n"
5518 if {[commitinview $nullid $curview]} {
5519 removefakerow $nullid
5520 }
5521 insertfakerow $nullid2 $viewmainheadid($curview)
5522 } elseif {!$isdiff && [commitinview $nullid2 $curview]} {
5523 if {[commitinview $nullid $curview]} {
5524 removefakerow $nullid
5525 }
5526 removefakerow $nullid2
5527 }
5528 return 0
5529}
5530
5531proc readdifffiles {fd serial inst} {
5532 global viewmainheadid nullid nullid2 curview
5533 global commitinfo commitdata lserial
5534
5535 set isdiff 1
5536 if {[gets $fd line] < 0} {
5537 if {![eof $fd]} {
5538 return 1
5539 }
5540 set isdiff 0
5541 }
5542 # we only need to see one line and we don't really care what it says...
5543 stop_instance $inst
5544
5545 if {$serial != $lserial} {
5546 return 0
5547 }
5548
5549 if {$isdiff && ![commitinview $nullid $curview]} {
5550 # add the line for the local diff to the graph
5551 set hl [mc "Local uncommitted changes, not checked in to index"]
5552 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
5553 set commitdata($nullid) "\n $hl\n"
5554 if {[commitinview $nullid2 $curview]} {
5555 set p $nullid2
5556 } else {
5557 set p $viewmainheadid($curview)
5558 }
5559 insertfakerow $nullid $p
5560 } elseif {!$isdiff && [commitinview $nullid $curview]} {
5561 removefakerow $nullid
5562 }
5563 return 0
5564}
5565
5566proc nextuse {id row} {
5567 global curview children
5568
5569 if {[info exists children($curview,$id)]} {
5570 foreach kid $children($curview,$id) {
5571 if {![commitinview $kid $curview]} {
5572 return -1
5573 }
5574 if {[rowofcommit $kid] > $row} {
5575 return [rowofcommit $kid]
5576 }
5577 }
5578 }
5579 if {[commitinview $id $curview]} {
5580 return [rowofcommit $id]
5581 }
5582 return -1
5583}
5584
5585proc prevuse {id row} {
5586 global curview children
5587
5588 set ret -1
5589 if {[info exists children($curview,$id)]} {
5590 foreach kid $children($curview,$id) {
5591 if {![commitinview $kid $curview]} break
5592 if {[rowofcommit $kid] < $row} {
5593 set ret [rowofcommit $kid]
5594 }
5595 }
5596 }
5597 return $ret
5598}
5599
5600proc make_idlist {row} {
5601 global displayorder parentlist uparrowlen downarrowlen mingaplen
5602 global commitidx curview children
5603
5604 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
5605 if {$r < 0} {
5606 set r 0
5607 }
5608 set ra [expr {$row - $downarrowlen}]
5609 if {$ra < 0} {
5610 set ra 0
5611 }
5612 set rb [expr {$row + $uparrowlen}]
5613 if {$rb > $commitidx($curview)} {
5614 set rb $commitidx($curview)
5615 }
5616 make_disporder $r [expr {$rb + 1}]
5617 set ids {}
5618 for {} {$r < $ra} {incr r} {
5619 set nextid [lindex $displayorder [expr {$r + 1}]]
5620 foreach p [lindex $parentlist $r] {
5621 if {$p eq $nextid} continue
5622 set rn [nextuse $p $r]
5623 if {$rn >= $row &&
5624 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
5625 lappend ids [list [ordertoken $p] $p]
5626 }
5627 }
5628 }
5629 for {} {$r < $row} {incr r} {
5630 set nextid [lindex $displayorder [expr {$r + 1}]]
5631 foreach p [lindex $parentlist $r] {
5632 if {$p eq $nextid} continue
5633 set rn [nextuse $p $r]
5634 if {$rn < 0 || $rn >= $row} {
5635 lappend ids [list [ordertoken $p] $p]
5636 }
5637 }
5638 }
5639 set id [lindex $displayorder $row]
5640 lappend ids [list [ordertoken $id] $id]
5641 while {$r < $rb} {
5642 foreach p [lindex $parentlist $r] {
5643 set firstkid [lindex $children($curview,$p) 0]
5644 if {[rowofcommit $firstkid] < $row} {
5645 lappend ids [list [ordertoken $p] $p]
5646 }
5647 }
5648 incr r
5649 set id [lindex $displayorder $r]
5650 if {$id ne {}} {
5651 set firstkid [lindex $children($curview,$id) 0]
5652 if {$firstkid ne {} && [rowofcommit $firstkid] < $row} {
5653 lappend ids [list [ordertoken $id] $id]
5654 }
5655 }
5656 }
5657 set idlist {}
5658 foreach idx [lsort -unique $ids] {
5659 lappend idlist [lindex $idx 1]
5660 }
5661 return $idlist
5662}
5663
5664proc rowsequal {a b} {
5665 while {[set i [lsearch -exact $a {}]] >= 0} {
5666 set a [lreplace $a $i $i]
5667 }
5668 while {[set i [lsearch -exact $b {}]] >= 0} {
5669 set b [lreplace $b $i $i]
5670 }
5671 return [expr {$a eq $b}]
5672}
5673
5674proc makeupline {id row rend col} {
5675 global rowidlist uparrowlen downarrowlen mingaplen
5676
5677 for {set r $rend} {1} {set r $rstart} {
5678 set rstart [prevuse $id $r]
5679 if {$rstart < 0} return
5680 if {$rstart < $row} break
5681 }
5682 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
5683 set rstart [expr {$rend - $uparrowlen - 1}]
5684 }
5685 for {set r $rstart} {[incr r] <= $row} {} {
5686 set idlist [lindex $rowidlist $r]
5687 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
5688 set col [idcol $idlist $id $col]
5689 lset rowidlist $r [linsert $idlist $col $id]
5690 changedrow $r
5691 }
5692 }
5693}
5694
5695proc layoutrows {row endrow} {
5696 global rowidlist rowisopt rowfinal displayorder
5697 global uparrowlen downarrowlen maxwidth mingaplen
5698 global children parentlist
5699 global commitidx viewcomplete curview
5700
5701 make_disporder [expr {$row - 1}] [expr {$endrow + $uparrowlen}]
5702 set idlist {}
5703 if {$row > 0} {
5704 set rm1 [expr {$row - 1}]
5705 foreach id [lindex $rowidlist $rm1] {
5706 if {$id ne {}} {
5707 lappend idlist $id
5708 }
5709 }
5710 set final [lindex $rowfinal $rm1]
5711 }
5712 for {} {$row < $endrow} {incr row} {
5713 set rm1 [expr {$row - 1}]
5714 if {$rm1 < 0 || $idlist eq {}} {
5715 set idlist [make_idlist $row]
5716 set final 1
5717 } else {
5718 set id [lindex $displayorder $rm1]
5719 set col [lsearch -exact $idlist $id]
5720 set idlist [lreplace $idlist $col $col]
5721 foreach p [lindex $parentlist $rm1] {
5722 if {[lsearch -exact $idlist $p] < 0} {
5723 set col [idcol $idlist $p $col]
5724 set idlist [linsert $idlist $col $p]
5725 # if not the first child, we have to insert a line going up
5726 if {$id ne [lindex $children($curview,$p) 0]} {
5727 makeupline $p $rm1 $row $col
5728 }
5729 }
5730 }
5731 set id [lindex $displayorder $row]
5732 if {$row > $downarrowlen} {
5733 set termrow [expr {$row - $downarrowlen - 1}]
5734 foreach p [lindex $parentlist $termrow] {
5735 set i [lsearch -exact $idlist $p]
5736 if {$i < 0} continue
5737 set nr [nextuse $p $termrow]
5738 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
5739 set idlist [lreplace $idlist $i $i]
5740 }
5741 }
5742 }
5743 set col [lsearch -exact $idlist $id]
5744 if {$col < 0} {
5745 set col [idcol $idlist $id]
5746 set idlist [linsert $idlist $col $id]
5747 if {$children($curview,$id) ne {}} {
5748 makeupline $id $rm1 $row $col
5749 }
5750 }
5751 set r [expr {$row + $uparrowlen - 1}]
5752 if {$r < $commitidx($curview)} {
5753 set x $col
5754 foreach p [lindex $parentlist $r] {
5755 if {[lsearch -exact $idlist $p] >= 0} continue
5756 set fk [lindex $children($curview,$p) 0]
5757 if {[rowofcommit $fk] < $row} {
5758 set x [idcol $idlist $p $x]
5759 set idlist [linsert $idlist $x $p]
5760 }
5761 }
5762 if {[incr r] < $commitidx($curview)} {
5763 set p [lindex $displayorder $r]
5764 if {[lsearch -exact $idlist $p] < 0} {
5765 set fk [lindex $children($curview,$p) 0]
5766 if {$fk ne {} && [rowofcommit $fk] < $row} {
5767 set x [idcol $idlist $p $x]
5768 set idlist [linsert $idlist $x $p]
5769 }
5770 }
5771 }
5772 }
5773 }
5774 if {$final && !$viewcomplete($curview) &&
5775 $row + $uparrowlen + $mingaplen + $downarrowlen
5776 >= $commitidx($curview)} {
5777 set final 0
5778 }
5779 set l [llength $rowidlist]
5780 if {$row == $l} {
5781 lappend rowidlist $idlist
5782 lappend rowisopt 0
5783 lappend rowfinal $final
5784 } elseif {$row < $l} {
5785 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
5786 lset rowidlist $row $idlist
5787 changedrow $row
5788 }
5789 lset rowfinal $row $final
5790 } else {
5791 set pad [ntimes [expr {$row - $l}] {}]
5792 set rowidlist [concat $rowidlist $pad]
5793 lappend rowidlist $idlist
5794 set rowfinal [concat $rowfinal $pad]
5795 lappend rowfinal $final
5796 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
5797 }
5798 }
5799 return $row
5800}
5801
5802proc changedrow {row} {
5803 global displayorder iddrawn rowisopt need_redisplay
5804
5805 set l [llength $rowisopt]
5806 if {$row < $l} {
5807 lset rowisopt $row 0
5808 if {$row + 1 < $l} {
5809 lset rowisopt [expr {$row + 1}] 0
5810 if {$row + 2 < $l} {
5811 lset rowisopt [expr {$row + 2}] 0
5812 }
5813 }
5814 }
5815 set id [lindex $displayorder $row]
5816 if {[info exists iddrawn($id)]} {
5817 set need_redisplay 1
5818 }
5819}
5820
5821proc insert_pad {row col npad} {
5822 global rowidlist
5823
5824 set pad [ntimes $npad {}]
5825 set idlist [lindex $rowidlist $row]
5826 set bef [lrange $idlist 0 [expr {$col - 1}]]
5827 set aft [lrange $idlist $col end]
5828 set i [lsearch -exact $aft {}]
5829 if {$i > 0} {
5830 set aft [lreplace $aft $i $i]
5831 }
5832 lset rowidlist $row [concat $bef $pad $aft]
5833 changedrow $row
5834}
5835
5836proc optimize_rows {row col endrow} {
5837 global rowidlist rowisopt displayorder curview children
5838
5839 if {$row < 1} {
5840 set row 1
5841 }
5842 for {} {$row < $endrow} {incr row; set col 0} {
5843 if {[lindex $rowisopt $row]} continue
5844 set haspad 0
5845 set y0 [expr {$row - 1}]
5846 set ym [expr {$row - 2}]
5847 set idlist [lindex $rowidlist $row]
5848 set previdlist [lindex $rowidlist $y0]
5849 if {$idlist eq {} || $previdlist eq {}} continue
5850 if {$ym >= 0} {
5851 set pprevidlist [lindex $rowidlist $ym]
5852 if {$pprevidlist eq {}} continue
5853 } else {
5854 set pprevidlist {}
5855 }
5856 set x0 -1
5857 set xm -1
5858 for {} {$col < [llength $idlist]} {incr col} {
5859 set id [lindex $idlist $col]
5860 if {[lindex $previdlist $col] eq $id} continue
5861 if {$id eq {}} {
5862 set haspad 1
5863 continue
5864 }
5865 set x0 [lsearch -exact $previdlist $id]
5866 if {$x0 < 0} continue
5867 set z [expr {$x0 - $col}]
5868 set isarrow 0
5869 set z0 {}
5870 if {$ym >= 0} {
5871 set xm [lsearch -exact $pprevidlist $id]
5872 if {$xm >= 0} {
5873 set z0 [expr {$xm - $x0}]
5874 }
5875 }
5876 if {$z0 eq {}} {
5877 # if row y0 is the first child of $id then it's not an arrow
5878 if {[lindex $children($curview,$id) 0] ne
5879 [lindex $displayorder $y0]} {
5880 set isarrow 1
5881 }
5882 }
5883 if {!$isarrow && $id ne [lindex $displayorder $row] &&
5884 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
5885 set isarrow 1
5886 }
5887 # Looking at lines from this row to the previous row,
5888 # make them go straight up if they end in an arrow on
5889 # the previous row; otherwise make them go straight up
5890 # or at 45 degrees.
5891 if {$z < -1 || ($z < 0 && $isarrow)} {
5892 # Line currently goes left too much;
5893 # insert pads in the previous row, then optimize it
5894 set npad [expr {-1 - $z + $isarrow}]
5895 insert_pad $y0 $x0 $npad
5896 if {$y0 > 0} {
5897 optimize_rows $y0 $x0 $row
5898 }
5899 set previdlist [lindex $rowidlist $y0]
5900 set x0 [lsearch -exact $previdlist $id]
5901 set z [expr {$x0 - $col}]
5902 if {$z0 ne {}} {
5903 set pprevidlist [lindex $rowidlist $ym]
5904 set xm [lsearch -exact $pprevidlist $id]
5905 set z0 [expr {$xm - $x0}]
5906 }
5907 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
5908 # Line currently goes right too much;
5909 # insert pads in this line
5910 set npad [expr {$z - 1 + $isarrow}]
5911 insert_pad $row $col $npad
5912 set idlist [lindex $rowidlist $row]
5913 incr col $npad
5914 set z [expr {$x0 - $col}]
5915 set haspad 1
5916 }
5917 if {$z0 eq {} && !$isarrow && $ym >= 0} {
5918 # this line links to its first child on row $row-2
5919 set id [lindex $displayorder $ym]
5920 set xc [lsearch -exact $pprevidlist $id]
5921 if {$xc >= 0} {
5922 set z0 [expr {$xc - $x0}]
5923 }
5924 }
5925 # avoid lines jigging left then immediately right
5926 if {$z0 ne {} && $z < 0 && $z0 > 0} {
5927 insert_pad $y0 $x0 1
5928 incr x0
5929 optimize_rows $y0 $x0 $row
5930 set previdlist [lindex $rowidlist $y0]
5931 }
5932 }
5933 if {!$haspad} {
5934 # Find the first column that doesn't have a line going right
5935 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
5936 set id [lindex $idlist $col]
5937 if {$id eq {}} break
5938 set x0 [lsearch -exact $previdlist $id]
5939 if {$x0 < 0} {
5940 # check if this is the link to the first child
5941 set kid [lindex $displayorder $y0]
5942 if {[lindex $children($curview,$id) 0] eq $kid} {
5943 # it is, work out offset to child
5944 set x0 [lsearch -exact $previdlist $kid]
5945 }
5946 }
5947 if {$x0 <= $col} break
5948 }
5949 # Insert a pad at that column as long as it has a line and
5950 # isn't the last column
5951 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
5952 set idlist [linsert $idlist $col {}]
5953 lset rowidlist $row $idlist
5954 changedrow $row
5955 }
5956 }
5957 }
5958}
5959
5960proc xc {row col} {
5961 global canvx0 linespc
5962 return [expr {$canvx0 + $col * $linespc}]
5963}
5964
5965proc yc {row} {
5966 global canvy0 linespc
5967 return [expr {$canvy0 + $row * $linespc}]
5968}
5969
5970proc linewidth {id} {
5971 global thickerline lthickness
5972
5973 set wid $lthickness
5974 if {[info exists thickerline] && $id eq $thickerline} {
5975 set wid [expr {2 * $lthickness}]
5976 }
5977 return $wid
5978}
5979
5980proc rowranges {id} {
5981 global curview children uparrowlen downarrowlen
5982 global rowidlist
5983
5984 set kids $children($curview,$id)
5985 if {$kids eq {}} {
5986 return {}
5987 }
5988 set ret {}
5989 lappend kids $id
5990 foreach child $kids {
5991 if {![commitinview $child $curview]} break
5992 set row [rowofcommit $child]
5993 if {![info exists prev]} {
5994 lappend ret [expr {$row + 1}]
5995 } else {
5996 if {$row <= $prevrow} {
5997 puts "oops children of [shortids $id] out of order [shortids $child] $row <= [shortids $prev] $prevrow"
5998 }
5999 # see if the line extends the whole way from prevrow to row
6000 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
6001 [lsearch -exact [lindex $rowidlist \
6002 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
6003 # it doesn't, see where it ends
6004 set r [expr {$prevrow + $downarrowlen}]
6005 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
6006 while {[incr r -1] > $prevrow &&
6007 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
6008 } else {
6009 while {[incr r] <= $row &&
6010 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
6011 incr r -1
6012 }
6013 lappend ret $r
6014 # see where it starts up again
6015 set r [expr {$row - $uparrowlen}]
6016 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
6017 while {[incr r] < $row &&
6018 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
6019 } else {
6020 while {[incr r -1] >= $prevrow &&
6021 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
6022 incr r
6023 }
6024 lappend ret $r
6025 }
6026 }
6027 if {$child eq $id} {
6028 lappend ret $row
6029 }
6030 set prev $child
6031 set prevrow $row
6032 }
6033 return $ret
6034}
6035
6036proc drawlineseg {id row endrow arrowlow} {
6037 global rowidlist displayorder iddrawn linesegs
6038 global canv colormap linespc curview maxlinelen parentlist
6039
6040 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
6041 set le [expr {$row + 1}]
6042 set arrowhigh 1
6043 while {1} {
6044 set c [lsearch -exact [lindex $rowidlist $le] $id]
6045 if {$c < 0} {
6046 incr le -1
6047 break
6048 }
6049 lappend cols $c
6050 set x [lindex $displayorder $le]
6051 if {$x eq $id} {
6052 set arrowhigh 0
6053 break
6054 }
6055 if {[info exists iddrawn($x)] || $le == $endrow} {
6056 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
6057 if {$c >= 0} {
6058 lappend cols $c
6059 set arrowhigh 0
6060 }
6061 break
6062 }
6063 incr le
6064 }
6065 if {$le <= $row} {
6066 return $row
6067 }
6068
6069 set lines {}
6070 set i 0
6071 set joinhigh 0
6072 if {[info exists linesegs($id)]} {
6073 set lines $linesegs($id)
6074 foreach li $lines {
6075 set r0 [lindex $li 0]
6076 if {$r0 > $row} {
6077 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
6078 set joinhigh 1
6079 }
6080 break
6081 }
6082 incr i
6083 }
6084 }
6085 set joinlow 0
6086 if {$i > 0} {
6087 set li [lindex $lines [expr {$i-1}]]
6088 set r1 [lindex $li 1]
6089 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
6090 set joinlow 1
6091 }
6092 }
6093
6094 set x [lindex $cols [expr {$le - $row}]]
6095 set xp [lindex $cols [expr {$le - 1 - $row}]]
6096 set dir [expr {$xp - $x}]
6097 if {$joinhigh} {
6098 set ith [lindex $lines $i 2]
6099 set coords [$canv coords $ith]
6100 set ah [$canv itemcget $ith -arrow]
6101 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
6102 set x2 [lindex $cols [expr {$le + 1 - $row}]]
6103 if {$x2 ne {} && $x - $x2 == $dir} {
6104 set coords [lrange $coords 0 end-2]
6105 }
6106 } else {
6107 set coords [list [xc $le $x] [yc $le]]
6108 }
6109 if {$joinlow} {
6110 set itl [lindex $lines [expr {$i-1}] 2]
6111 set al [$canv itemcget $itl -arrow]
6112 set arrowlow [expr {$al eq "last" || $al eq "both"}]
6113 } elseif {$arrowlow} {
6114 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
6115 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
6116 set arrowlow 0
6117 }
6118 }
6119 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
6120 for {set y $le} {[incr y -1] > $row} {} {
6121 set x $xp
6122 set xp [lindex $cols [expr {$y - 1 - $row}]]
6123 set ndir [expr {$xp - $x}]
6124 if {$dir != $ndir || $xp < 0} {
6125 lappend coords [xc $y $x] [yc $y]
6126 }
6127 set dir $ndir
6128 }
6129 if {!$joinlow} {
6130 if {$xp < 0} {
6131 # join parent line to first child
6132 set ch [lindex $displayorder $row]
6133 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
6134 if {$xc < 0} {
6135 puts "oops: drawlineseg: child $ch not on row $row"
6136 } elseif {$xc != $x} {
6137 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
6138 set d [expr {int(0.5 * $linespc)}]
6139 set x1 [xc $row $x]
6140 if {$xc < $x} {
6141 set x2 [expr {$x1 - $d}]
6142 } else {
6143 set x2 [expr {$x1 + $d}]
6144 }
6145 set y2 [yc $row]
6146 set y1 [expr {$y2 + $d}]
6147 lappend coords $x1 $y1 $x2 $y2
6148 } elseif {$xc < $x - 1} {
6149 lappend coords [xc $row [expr {$x-1}]] [yc $row]
6150 } elseif {$xc > $x + 1} {
6151 lappend coords [xc $row [expr {$x+1}]] [yc $row]
6152 }
6153 set x $xc
6154 }
6155 lappend coords [xc $row $x] [yc $row]
6156 } else {
6157 set xn [xc $row $xp]
6158 set yn [yc $row]
6159 lappend coords $xn $yn
6160 }
6161 if {!$joinhigh} {
6162 assigncolor $id
6163 set t [$canv create line $coords -width [linewidth $id] \
6164 -fill $colormap($id) -tags lines.$id -arrow $arrow]
6165 $canv lower $t
6166 bindline $t $id
6167 set lines [linsert $lines $i [list $row $le $t]]
6168 } else {
6169 $canv coords $ith $coords
6170 if {$arrow ne $ah} {
6171 $canv itemconf $ith -arrow $arrow
6172 }
6173 lset lines $i 0 $row
6174 }
6175 } else {
6176 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
6177 set ndir [expr {$xo - $xp}]
6178 set clow [$canv coords $itl]
6179 if {$dir == $ndir} {
6180 set clow [lrange $clow 2 end]
6181 }
6182 set coords [concat $coords $clow]
6183 if {!$joinhigh} {
6184 lset lines [expr {$i-1}] 1 $le
6185 } else {
6186 # coalesce two pieces
6187 $canv delete $ith
6188 set b [lindex $lines [expr {$i-1}] 0]
6189 set e [lindex $lines $i 1]
6190 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
6191 }
6192 $canv coords $itl $coords
6193 if {$arrow ne $al} {
6194 $canv itemconf $itl -arrow $arrow
6195 }
6196 }
6197
6198 set linesegs($id) $lines
6199 return $le
6200}
6201
6202proc drawparentlinks {id row} {
6203 global rowidlist canv colormap curview parentlist
6204 global idpos linespc
6205
6206 set rowids [lindex $rowidlist $row]
6207 set col [lsearch -exact $rowids $id]
6208 if {$col < 0} return
6209 set olds [lindex $parentlist $row]
6210 set row2 [expr {$row + 1}]
6211 set x [xc $row $col]
6212 set y [yc $row]
6213 set y2 [yc $row2]
6214 set d [expr {int(0.5 * $linespc)}]
6215 set ymid [expr {$y + $d}]
6216 set ids [lindex $rowidlist $row2]
6217 # rmx = right-most X coord used
6218 set rmx 0
6219 foreach p $olds {
6220 set i [lsearch -exact $ids $p]
6221 if {$i < 0} {
6222 puts "oops, parent $p of $id not in list"
6223 continue
6224 }
6225 set x2 [xc $row2 $i]
6226 if {$x2 > $rmx} {
6227 set rmx $x2
6228 }
6229 set j [lsearch -exact $rowids $p]
6230 if {$j < 0} {
6231 # drawlineseg will do this one for us
6232 continue
6233 }
6234 assigncolor $p
6235 # should handle duplicated parents here...
6236 set coords [list $x $y]
6237 if {$i != $col} {
6238 # if attaching to a vertical segment, draw a smaller
6239 # slant for visual distinctness
6240 if {$i == $j} {
6241 if {$i < $col} {
6242 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
6243 } else {
6244 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
6245 }
6246 } elseif {$i < $col && $i < $j} {
6247 # segment slants towards us already
6248 lappend coords [xc $row $j] $y
6249 } else {
6250 if {$i < $col - 1} {
6251 lappend coords [expr {$x2 + $linespc}] $y
6252 } elseif {$i > $col + 1} {
6253 lappend coords [expr {$x2 - $linespc}] $y
6254 }
6255 lappend coords $x2 $y2
6256 }
6257 } else {
6258 lappend coords $x2 $y2
6259 }
6260 set t [$canv create line $coords -width [linewidth $p] \
6261 -fill $colormap($p) -tags lines.$p]
6262 $canv lower $t
6263 bindline $t $p
6264 }
6265 if {$rmx > [lindex $idpos($id) 1]} {
6266 lset idpos($id) 1 $rmx
6267 redrawtags $id
6268 }
6269}
6270
6271proc drawlines {id} {
6272 global canv
6273
6274 $canv itemconf lines.$id -width [linewidth $id]
6275}
6276
6277proc drawcmittext {id row col} {
6278 global linespc canv canv2 canv3 fgcolor curview
6279 global cmitlisted commitinfo rowidlist parentlist
6280 global rowtextx idpos idtags idheads idotherrefs
6281 global linehtag linentag linedtag selectedline
6282 global canvxmax boldids boldnameids fgcolor markedid
6283 global mainheadid nullid nullid2 circleitem circlecolors ctxbut
6284 global mainheadcirclecolor workingfilescirclecolor indexcirclecolor
6285 global circleoutlinecolor
6286
6287 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
6288 set listed $cmitlisted($curview,$id)
6289 if {$id eq $nullid} {
6290 set ofill $workingfilescirclecolor
6291 } elseif {$id eq $nullid2} {
6292 set ofill $indexcirclecolor
6293 } elseif {$id eq $mainheadid} {
6294 set ofill $mainheadcirclecolor
6295 } else {
6296 set ofill [lindex $circlecolors $listed]
6297 }
6298 set x [xc $row $col]
6299 set y [yc $row]
6300 set orad [expr {$linespc / 3}]
6301 if {$listed <= 2} {
6302 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
6303 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6304 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6305 } elseif {$listed == 3} {
6306 # triangle pointing left for left-side commits
6307 set t [$canv create polygon \
6308 [expr {$x - $orad}] $y \
6309 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
6310 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
6311 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6312 } else {
6313 # triangle pointing right for right-side commits
6314 set t [$canv create polygon \
6315 [expr {$x + $orad - 1}] $y \
6316 [expr {$x - $orad}] [expr {$y - $orad}] \
6317 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
6318 -fill $ofill -outline $circleoutlinecolor -width 1 -tags circle]
6319 }
6320 set circleitem($row) $t
6321 $canv raise $t
6322 $canv bind $t <1> {selcanvline {} %x %y}
6323 set rmx [llength [lindex $rowidlist $row]]
6324 set olds [lindex $parentlist $row]
6325 if {$olds ne {}} {
6326 set nextids [lindex $rowidlist [expr {$row + 1}]]
6327 foreach p $olds {
6328 set i [lsearch -exact $nextids $p]
6329 if {$i > $rmx} {
6330 set rmx $i
6331 }
6332 }
6333 }
6334 set xt [xc $row $rmx]
6335 set rowtextx($row) $xt
6336 set idpos($id) [list $x $xt $y]
6337 if {[info exists idtags($id)] || [info exists idheads($id)]
6338 || [info exists idotherrefs($id)]} {
6339 set xt [drawtags $id $x $xt $y]
6340 }
6341 if {[lindex $commitinfo($id) 6] > 0} {
6342 set xt [drawnotesign $xt $y]
6343 }
6344 set headline [lindex $commitinfo($id) 0]
6345 set name [lindex $commitinfo($id) 1]
6346 set date [lindex $commitinfo($id) 2]
6347 set date [formatdate $date]
6348 set font mainfont
6349 set nfont mainfont
6350 set isbold [ishighlighted $id]
6351 if {$isbold > 0} {
6352 lappend boldids $id
6353 set font mainfontbold
6354 if {$isbold > 1} {
6355 lappend boldnameids $id
6356 set nfont mainfontbold
6357 }
6358 }
6359 set linehtag($id) [$canv create text $xt $y -anchor w -fill $fgcolor \
6360 -text $headline -font $font -tags text]
6361 $canv bind $linehtag($id) $ctxbut "rowmenu %X %Y $id"
6362 set linentag($id) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
6363 -text $name -font $nfont -tags text]
6364 set linedtag($id) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
6365 -text $date -font mainfont -tags text]
6366 if {$selectedline == $row} {
6367 make_secsel $id
6368 }
6369 if {[info exists markedid] && $markedid eq $id} {
6370 make_idmark $id
6371 }
6372 set xr [expr {$xt + [font measure $font $headline]}]
6373 if {$xr > $canvxmax} {
6374 set canvxmax $xr
6375 setcanvscroll
6376 }
6377}
6378
6379proc drawcmitrow {row} {
6380 global displayorder rowidlist nrows_drawn
6381 global iddrawn markingmatches
6382 global commitinfo numcommits
6383 global filehighlight fhighlights findpattern nhighlights
6384 global hlview vhighlights
6385 global highlight_related rhighlights
6386
6387 if {$row >= $numcommits} return
6388
6389 set id [lindex $displayorder $row]
6390 if {[info exists hlview] && ![info exists vhighlights($id)]} {
6391 askvhighlight $row $id
6392 }
6393 if {[info exists filehighlight] && ![info exists fhighlights($id)]} {
6394 askfilehighlight $row $id
6395 }
6396 if {$findpattern ne {} && ![info exists nhighlights($id)]} {
6397 askfindhighlight $row $id
6398 }
6399 if {$highlight_related ne [mc "None"] && ![info exists rhighlights($id)]} {
6400 askrelhighlight $row $id
6401 }
6402 if {![info exists iddrawn($id)]} {
6403 set col [lsearch -exact [lindex $rowidlist $row] $id]
6404 if {$col < 0} {
6405 puts "oops, row $row id $id not in list"
6406 return
6407 }
6408 if {![info exists commitinfo($id)]} {
6409 getcommit $id
6410 }
6411 assigncolor $id
6412 drawcmittext $id $row $col
6413 set iddrawn($id) 1
6414 incr nrows_drawn
6415 }
6416 if {$markingmatches} {
6417 markrowmatches $row $id
6418 }
6419}
6420
6421proc drawcommits {row {endrow {}}} {
6422 global numcommits iddrawn displayorder curview need_redisplay
6423 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
6424
6425 if {$row < 0} {
6426 set row 0
6427 }
6428 if {$endrow eq {}} {
6429 set endrow $row
6430 }
6431 if {$endrow >= $numcommits} {
6432 set endrow [expr {$numcommits - 1}]
6433 }
6434
6435 set rl1 [expr {$row - $downarrowlen - 3}]
6436 if {$rl1 < 0} {
6437 set rl1 0
6438 }
6439 set ro1 [expr {$row - 3}]
6440 if {$ro1 < 0} {
6441 set ro1 0
6442 }
6443 set r2 [expr {$endrow + $uparrowlen + 3}]
6444 if {$r2 > $numcommits} {
6445 set r2 $numcommits
6446 }
6447 for {set r $rl1} {$r < $r2} {incr r} {
6448 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
6449 if {$rl1 < $r} {
6450 layoutrows $rl1 $r
6451 }
6452 set rl1 [expr {$r + 1}]
6453 }
6454 }
6455 if {$rl1 < $r} {
6456 layoutrows $rl1 $r
6457 }
6458 optimize_rows $ro1 0 $r2
6459 if {$need_redisplay || $nrows_drawn > 2000} {
6460 clear_display
6461 }
6462
6463 # make the lines join to already-drawn rows either side
6464 set r [expr {$row - 1}]
6465 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
6466 set r $row
6467 }
6468 set er [expr {$endrow + 1}]
6469 if {$er >= $numcommits ||
6470 ![info exists iddrawn([lindex $displayorder $er])]} {
6471 set er $endrow
6472 }
6473 for {} {$r <= $er} {incr r} {
6474 set id [lindex $displayorder $r]
6475 set wasdrawn [info exists iddrawn($id)]
6476 drawcmitrow $r
6477 if {$r == $er} break
6478 set nextid [lindex $displayorder [expr {$r + 1}]]
6479 if {$wasdrawn && [info exists iddrawn($nextid)]} continue
6480 drawparentlinks $id $r
6481
6482 set rowids [lindex $rowidlist $r]
6483 foreach lid $rowids {
6484 if {$lid eq {}} continue
6485 if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
6486 if {$lid eq $id} {
6487 # see if this is the first child of any of its parents
6488 foreach p [lindex $parentlist $r] {
6489 if {[lsearch -exact $rowids $p] < 0} {
6490 # make this line extend up to the child
6491 set lineend($p) [drawlineseg $p $r $er 0]
6492 }
6493 }
6494 } else {
6495 set lineend($lid) [drawlineseg $lid $r $er 1]
6496 }
6497 }
6498 }
6499}
6500
6501proc undolayout {row} {
6502 global uparrowlen mingaplen downarrowlen
6503 global rowidlist rowisopt rowfinal need_redisplay
6504
6505 set r [expr {$row - ($uparrowlen + $mingaplen + $downarrowlen)}]
6506 if {$r < 0} {
6507 set r 0
6508 }
6509 if {[llength $rowidlist] > $r} {
6510 incr r -1
6511 set rowidlist [lrange $rowidlist 0 $r]
6512 set rowfinal [lrange $rowfinal 0 $r]
6513 set rowisopt [lrange $rowisopt 0 $r]
6514 set need_redisplay 1
6515 run drawvisible
6516 }
6517}
6518
6519proc drawvisible {} {
6520 global canv linespc curview vrowmod selectedline targetrow targetid
6521 global need_redisplay cscroll numcommits
6522
6523 set fs [$canv yview]
6524 set ymax [lindex [$canv cget -scrollregion] 3]
6525 if {$ymax eq {} || $ymax == 0 || $numcommits == 0} return
6526 set f0 [lindex $fs 0]
6527 set f1 [lindex $fs 1]
6528 set y0 [expr {int($f0 * $ymax)}]
6529 set y1 [expr {int($f1 * $ymax)}]
6530
6531 if {[info exists targetid]} {
6532 if {[commitinview $targetid $curview]} {
6533 set r [rowofcommit $targetid]
6534 if {$r != $targetrow} {
6535 # Fix up the scrollregion and change the scrolling position
6536 # now that our target row has moved.
6537 set diff [expr {($r - $targetrow) * $linespc}]
6538 set targetrow $r
6539 setcanvscroll
6540 set ymax [lindex [$canv cget -scrollregion] 3]
6541 incr y0 $diff
6542 incr y1 $diff
6543 set f0 [expr {$y0 / $ymax}]
6544 set f1 [expr {$y1 / $ymax}]
6545 allcanvs yview moveto $f0
6546 $cscroll set $f0 $f1
6547 set need_redisplay 1
6548 }
6549 } else {
6550 unset targetid
6551 }
6552 }
6553
6554 set row [expr {int(($y0 - 3) / $linespc) - 1}]
6555 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
6556 if {$endrow >= $vrowmod($curview)} {
6557 update_arcrows $curview
6558 }
6559 if {$selectedline ne {} &&
6560 $row <= $selectedline && $selectedline <= $endrow} {
6561 set targetrow $selectedline
6562 } elseif {[info exists targetid]} {
6563 set targetrow [expr {int(($row + $endrow) / 2)}]
6564 }
6565 if {[info exists targetrow]} {
6566 if {$targetrow >= $numcommits} {
6567 set targetrow [expr {$numcommits - 1}]
6568 }
6569 set targetid [commitonrow $targetrow]
6570 }
6571 drawcommits $row $endrow
6572}
6573
6574proc clear_display {} {
6575 global iddrawn linesegs need_redisplay nrows_drawn
6576 global vhighlights fhighlights nhighlights rhighlights
6577 global linehtag linentag linedtag boldids boldnameids
6578
6579 allcanvs delete all
6580 unset -nocomplain iddrawn
6581 unset -nocomplain linesegs
6582 unset -nocomplain linehtag
6583 unset -nocomplain linentag
6584 unset -nocomplain linedtag
6585 set boldids {}
6586 set boldnameids {}
6587 unset -nocomplain vhighlights
6588 unset -nocomplain fhighlights
6589 unset -nocomplain nhighlights
6590 unset -nocomplain rhighlights
6591 set need_redisplay 0
6592 set nrows_drawn 0
6593}
6594
6595proc findcrossings {id} {
6596 global rowidlist parentlist numcommits displayorder
6597
6598 set cross {}
6599 set ccross {}
6600 foreach {s e} [rowranges $id] {
6601 if {$e >= $numcommits} {
6602 set e [expr {$numcommits - 1}]
6603 }
6604 if {$e <= $s} continue
6605 for {set row $e} {[incr row -1] >= $s} {} {
6606 set x [lsearch -exact [lindex $rowidlist $row] $id]
6607 if {$x < 0} break
6608 set olds [lindex $parentlist $row]
6609 set kid [lindex $displayorder $row]
6610 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
6611 if {$kidx < 0} continue
6612 set nextrow [lindex $rowidlist [expr {$row + 1}]]
6613 foreach p $olds {
6614 set px [lsearch -exact $nextrow $p]
6615 if {$px < 0} continue
6616 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
6617 if {[lsearch -exact $ccross $p] >= 0} continue
6618 if {$x == $px + ($kidx < $px? -1: 1)} {
6619 lappend ccross $p
6620 } elseif {[lsearch -exact $cross $p] < 0} {
6621 lappend cross $p
6622 }
6623 }
6624 }
6625 }
6626 }
6627 return [concat $ccross {{}} $cross]
6628}
6629
6630proc assigncolor {id} {
6631 global colormap colors nextcolor
6632 global parents children children curview
6633
6634 if {[info exists colormap($id)]} return
6635 set ncolors [llength $colors]
6636 if {[info exists children($curview,$id)]} {
6637 set kids $children($curview,$id)
6638 } else {
6639 set kids {}
6640 }
6641 if {[llength $kids] == 1} {
6642 set child [lindex $kids 0]
6643 if {[info exists colormap($child)]
6644 && [llength $parents($curview,$child)] == 1} {
6645 set colormap($id) $colormap($child)
6646 return
6647 }
6648 }
6649 set badcolors {}
6650 set origbad {}
6651 foreach x [findcrossings $id] {
6652 if {$x eq {}} {
6653 # delimiter between corner crossings and other crossings
6654 if {[llength $badcolors] >= $ncolors - 1} break
6655 set origbad $badcolors
6656 }
6657 if {[info exists colormap($x)]
6658 && [lsearch -exact $badcolors $colormap($x)] < 0} {
6659 lappend badcolors $colormap($x)
6660 }
6661 }
6662 if {[llength $badcolors] >= $ncolors} {
6663 set badcolors $origbad
6664 }
6665 set origbad $badcolors
6666 if {[llength $badcolors] < $ncolors - 1} {
6667 foreach child $kids {
6668 if {[info exists colormap($child)]
6669 && [lsearch -exact $badcolors $colormap($child)] < 0} {
6670 lappend badcolors $colormap($child)
6671 }
6672 foreach p $parents($curview,$child) {
6673 if {[info exists colormap($p)]
6674 && [lsearch -exact $badcolors $colormap($p)] < 0} {
6675 lappend badcolors $colormap($p)
6676 }
6677 }
6678 }
6679 if {[llength $badcolors] >= $ncolors} {
6680 set badcolors $origbad
6681 }
6682 }
6683 for {set i 0} {$i <= $ncolors} {incr i} {
6684 set c [lindex $colors $nextcolor]
6685 if {[incr nextcolor] >= $ncolors} {
6686 set nextcolor 0
6687 }
6688 if {[lsearch -exact $badcolors $c]} break
6689 }
6690 set colormap($id) $c
6691}
6692
6693proc bindline {t id} {
6694 global canv
6695
6696 $canv bind $t <Enter> "lineenter %x %y $id"
6697 $canv bind $t <Motion> "linemotion %x %y $id"
6698 $canv bind $t <Leave> "lineleave $id"
6699 $canv bind $t <Button-1> "lineclick %x %y $id 1"
6700}
6701
6702proc graph_pane_width {} {
6703 set g [.tf.histframe.pwclist sashpos 0]
6704 return [lindex $g 0]
6705}
6706
6707proc totalwidth {l font extra} {
6708 set tot 0
6709 foreach str $l {
6710 set tot [expr {$tot + [font measure $font $str] + $extra}]
6711 }
6712 return $tot
6713}
6714
6715proc drawtags {id x xt y1} {
6716 global idtags idheads idotherrefs mainhead
6717 global linespc lthickness
6718 global canv rowtextx curview fgcolor bgcolor ctxbut
6719 global headbgcolor headfgcolor headoutlinecolor remotebgcolor
6720 global tagbgcolor tagfgcolor tagoutlinecolor
6721 global reflinecolor
6722
6723 set marks {}
6724 set ntags 0
6725 set nheads 0
6726 set singletag 0
6727 set maxtags 3
6728 set maxtagpct 25
6729 set maxwidth [expr {[graph_pane_width] * $maxtagpct / 100}]
6730 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
6731 set extra [expr {$delta + $lthickness + $linespc}]
6732
6733 if {[info exists idtags($id)]} {
6734 set marks $idtags($id)
6735 set ntags [llength $marks]
6736 if {$ntags > $maxtags ||
6737 [totalwidth $marks mainfont $extra] > $maxwidth} {
6738 # show just a single "n tags..." tag
6739 set singletag 1
6740 if {$ntags == 1} {
6741 set marks [list "tag..."]
6742 } else {
6743 set marks [list [format "%d tags..." $ntags]]
6744 }
6745 set ntags 1
6746 }
6747 }
6748 if {[info exists idheads($id)]} {
6749 set marks [concat $marks $idheads($id)]
6750 set nheads [llength $idheads($id)]
6751 }
6752 if {[info exists idotherrefs($id)]} {
6753 set marks [concat $marks $idotherrefs($id)]
6754 }
6755 if {$marks eq {}} {
6756 return $xt
6757 }
6758
6759 set yt [expr {$y1 - 0.5 * $linespc}]
6760 set yb [expr {$yt + $linespc - 1}]
6761 set xvals {}
6762 set wvals {}
6763 set i -1
6764 foreach tag $marks {
6765 incr i
6766 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
6767 set wid [font measure mainfontbold $tag]
6768 } else {
6769 set wid [font measure mainfont $tag]
6770 }
6771 lappend xvals $xt
6772 lappend wvals $wid
6773 set xt [expr {$xt + $wid + $extra}]
6774 }
6775 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
6776 -width $lthickness -fill $reflinecolor -tags tag.$id]
6777 $canv lower $t
6778 foreach tag $marks x $xvals wid $wvals {
6779 set tag_quoted [string map {% %%} $tag]
6780 set xl [expr {$x + $delta}]
6781 set xr [expr {$x + $delta + $wid + $lthickness}]
6782 set font mainfont
6783 if {[incr ntags -1] >= 0} {
6784 # draw a tag
6785 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
6786 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
6787 -width 1 -outline $tagoutlinecolor -fill $tagbgcolor \
6788 -tags tag.$id]
6789 if {$singletag} {
6790 set tagclick [list showtags $id 1]
6791 } else {
6792 set tagclick [list showtag $tag_quoted 1]
6793 }
6794 $canv bind $t <1> $tagclick
6795 set rowtextx([rowofcommit $id]) [expr {$xr + $linespc}]
6796 } else {
6797 # draw a head or other ref
6798 if {[incr nheads -1] >= 0} {
6799 set col $headbgcolor
6800 if {$tag eq $mainhead} {
6801 set font mainfontbold
6802 }
6803 } else {
6804 set col "#ddddff"
6805 }
6806 set xl [expr {$xl - $delta/2}]
6807 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
6808 -width 1 -outline black -fill $col -tags tag.$id
6809 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
6810 set rwid [font measure mainfont $remoteprefix]
6811 set xi [expr {$x + 1}]
6812 set yti [expr {$yt + 1}]
6813 set xri [expr {$x + $rwid}]
6814 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
6815 -width 0 -fill $remotebgcolor -tags tag.$id
6816 }
6817 }
6818 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $headfgcolor \
6819 -font $font -tags [list tag.$id text]]
6820 if {$ntags >= 0} {
6821 $canv bind $t <1> $tagclick
6822 } elseif {$nheads >= 0} {
6823 $canv bind $t $ctxbut [list headmenu %X %Y $id $tag_quoted]
6824 }
6825 }
6826 return $xt
6827}
6828
6829proc drawnotesign {xt y} {
6830 global linespc canv fgcolor
6831
6832 set orad [expr {$linespc / 3}]
6833 set t [$canv create rectangle [expr {$xt - $orad}] [expr {$y - $orad}] \
6834 [expr {$xt + $orad - 1}] [expr {$y + $orad - 1}] \
6835 -fill yellow -outline $fgcolor -width 1 -tags circle]
6836 set xt [expr {$xt + $orad * 3}]
6837 return $xt
6838}
6839
6840proc xcoord {i level ln} {
6841 global canvx0 xspc1 xspc2
6842
6843 set x [expr {$canvx0 + $i * $xspc1($ln)}]
6844 if {$i > 0 && $i == $level} {
6845 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
6846 } elseif {$i > $level} {
6847 set x [expr {$x + $xspc2 - $xspc1($ln)}]
6848 }
6849 return $x
6850}
6851
6852proc show_status {msg} {
6853 global canv fgcolor
6854
6855 clear_display
6856 set_window_title
6857 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
6858 -tags text -fill $fgcolor
6859}
6860
6861# Don't change the text pane cursor if it is currently the hand cursor,
6862# showing that we are over a sha1 ID link.
6863proc settextcursor {c} {
6864 global ctext curtextcursor
6865
6866 if {[$ctext cget -cursor] == $curtextcursor} {
6867 $ctext config -cursor $c
6868 }
6869 set curtextcursor $c
6870}
6871
6872proc nowbusy {what {name {}}} {
6873 global isbusy busyname statusw
6874
6875 if {[array names isbusy] eq {}} {
6876 . config -cursor watch
6877 settextcursor watch
6878 }
6879 set isbusy($what) 1
6880 set busyname($what) $name
6881 if {$name ne {}} {
6882 $statusw conf -text $name
6883 }
6884}
6885
6886proc notbusy {what} {
6887 global isbusy maincursor textcursor busyname statusw
6888
6889 catch {
6890 unset isbusy($what)
6891 if {$busyname($what) ne {} &&
6892 [$statusw cget -text] eq $busyname($what)} {
6893 $statusw conf -text {}
6894 }
6895 }
6896 if {[array names isbusy] eq {}} {
6897 . config -cursor $maincursor
6898 settextcursor $textcursor
6899 }
6900}
6901
6902proc findmatches {f} {
6903 global findtype findstring
6904 if {$findtype == [mc "Regexp"]} {
6905 set matches [regexp -indices -all -inline $findstring $f]
6906 } else {
6907 set fs $findstring
6908 if {$findtype == [mc "IgnCase"]} {
6909 set f [string tolower $f]
6910 set fs [string tolower $fs]
6911 }
6912 set matches {}
6913 set i 0
6914 set l [string length $fs]
6915 while {[set j [string first $fs $f $i]] >= 0} {
6916 lappend matches [list $j [expr {$j+$l-1}]]
6917 set i [expr {$j + $l}]
6918 }
6919 }
6920 return $matches
6921}
6922
6923proc dofind {{dirn 1} {wrap 1}} {
6924 global findstring findstartline findcurline selectedline numcommits
6925 global gdttype filehighlight fh_serial find_dirn findallowwrap
6926
6927 if {[info exists find_dirn]} {
6928 if {$find_dirn == $dirn} return
6929 stopfinding
6930 }
6931 focus .
6932 if {$findstring eq {} || $numcommits == 0} return
6933 if {$selectedline eq {}} {
6934 set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
6935 } else {
6936 set findstartline $selectedline
6937 }
6938 set findcurline $findstartline
6939 nowbusy finding [mc "Searching"]
6940 if {$gdttype ne [mc "containing:"] && ![info exists filehighlight]} {
6941 after cancel do_file_hl $fh_serial
6942 do_file_hl $fh_serial
6943 }
6944 set find_dirn $dirn
6945 set findallowwrap $wrap
6946 run findmore
6947}
6948
6949proc stopfinding {} {
6950 global find_dirn findcurline fprogcoord
6951
6952 if {[info exists find_dirn]} {
6953 unset find_dirn
6954 unset findcurline
6955 notbusy finding
6956 set fprogcoord 0
6957 adjustprogress
6958 }
6959 stopblaming
6960}
6961
6962proc findmore {} {
6963 global commitdata commitinfo numcommits findpattern findloc
6964 global findstartline findcurline findallowwrap
6965 global find_dirn gdttype fhighlights fprogcoord
6966 global curview varcorder vrownum varccommits vrowmod
6967
6968 if {![info exists find_dirn]} {
6969 return 0
6970 }
6971 set fldtypes [list [mc "Headline"] [mc "Author"] "" [mc "Committer"] "" [mc "Comments"]]
6972 set l $findcurline
6973 set moretodo 0
6974 if {$find_dirn > 0} {
6975 incr l
6976 if {$l >= $numcommits} {
6977 set l 0
6978 }
6979 if {$l <= $findstartline} {
6980 set lim [expr {$findstartline + 1}]
6981 } else {
6982 set lim $numcommits
6983 set moretodo $findallowwrap
6984 }
6985 } else {
6986 if {$l == 0} {
6987 set l $numcommits
6988 }
6989 incr l -1
6990 if {$l >= $findstartline} {
6991 set lim [expr {$findstartline - 1}]
6992 } else {
6993 set lim -1
6994 set moretodo $findallowwrap
6995 }
6996 }
6997 set n [expr {($lim - $l) * $find_dirn}]
6998 if {$n > 500} {
6999 set n 500
7000 set moretodo 1
7001 }
7002 if {$l + ($find_dirn > 0? $n: 1) > $vrowmod($curview)} {
7003 update_arcrows $curview
7004 }
7005 set found 0
7006 set domore 1
7007 set ai [bsearch $vrownum($curview) $l]
7008 set a [lindex $varcorder($curview) $ai]
7009 set arow [lindex $vrownum($curview) $ai]
7010 set ids [lindex $varccommits($curview,$a)]
7011 set arowend [expr {$arow + [llength $ids]}]
7012 if {$gdttype eq [mc "containing:"]} {
7013 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
7014 if {$l < $arow || $l >= $arowend} {
7015 incr ai $find_dirn
7016 set a [lindex $varcorder($curview) $ai]
7017 set arow [lindex $vrownum($curview) $ai]
7018 set ids [lindex $varccommits($curview,$a)]
7019 set arowend [expr {$arow + [llength $ids]}]
7020 }
7021 set id [lindex $ids [expr {$l - $arow}]]
7022 # shouldn't happen unless git log doesn't give all the commits...
7023 if {![info exists commitdata($id)] ||
7024 ![doesmatch $commitdata($id)]} {
7025 continue
7026 }
7027 if {![info exists commitinfo($id)]} {
7028 getcommit $id
7029 }
7030 set info $commitinfo($id)
7031 foreach f $info ty $fldtypes {
7032 if {$ty eq ""} continue
7033 if {($findloc eq [mc "All fields"] || $findloc eq $ty) &&
7034 [doesmatch $f]} {
7035 set found 1
7036 break
7037 }
7038 }
7039 if {$found} break
7040 }
7041 } else {
7042 for {} {$n > 0} {incr n -1; incr l $find_dirn} {
7043 if {$l < $arow || $l >= $arowend} {
7044 incr ai $find_dirn
7045 set a [lindex $varcorder($curview) $ai]
7046 set arow [lindex $vrownum($curview) $ai]
7047 set ids [lindex $varccommits($curview,$a)]
7048 set arowend [expr {$arow + [llength $ids]}]
7049 }
7050 set id [lindex $ids [expr {$l - $arow}]]
7051 if {![info exists fhighlights($id)]} {
7052 # this sets fhighlights($id) to -1
7053 askfilehighlight $l $id
7054 }
7055 if {$fhighlights($id) > 0} {
7056 set found $domore
7057 break
7058 }
7059 if {$fhighlights($id) < 0} {
7060 if {$domore} {
7061 set domore 0
7062 set findcurline [expr {$l - $find_dirn}]
7063 }
7064 }
7065 }
7066 }
7067 if {$found || ($domore && !$moretodo)} {
7068 unset findcurline
7069 unset find_dirn
7070 notbusy finding
7071 set fprogcoord 0
7072 adjustprogress
7073 if {$found} {
7074 findselectline $l
7075 } else {
7076 bell
7077 }
7078 return 0
7079 }
7080 if {!$domore} {
7081 flushhighlights
7082 } else {
7083 set findcurline [expr {$l - $find_dirn}]
7084 }
7085 set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
7086 if {$n < 0} {
7087 incr n $numcommits
7088 }
7089 set fprogcoord [expr {$n * 1.0 / $numcommits}]
7090 adjustprogress
7091 return $domore
7092}
7093
7094proc findselectline {l} {
7095 global findloc commentend ctext findcurline markingmatches gdttype
7096
7097 set markingmatches [expr {$gdttype eq [mc "containing:"]}]
7098 set findcurline $l
7099 selectline $l 1
7100 if {$markingmatches &&
7101 ($findloc eq [mc "All fields"] || $findloc eq [mc "Comments"])} {
7102 # highlight the matches in the comments
7103 set f [$ctext get 1.0 $commentend]
7104 set matches [findmatches $f]
7105 foreach match $matches {
7106 set start [lindex $match 0]
7107 set end [expr {[lindex $match 1] + 1}]
7108 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
7109 }
7110 }
7111 drawvisible
7112}
7113
7114# mark the bits of a headline or author that match a find string
7115proc markmatches {canv l str tag matches font row} {
7116 global selectedline foundbgcolor
7117
7118 set bbox [$canv bbox $tag]
7119 set x0 [lindex $bbox 0]
7120 set y0 [lindex $bbox 1]
7121 set y1 [lindex $bbox 3]
7122 foreach match $matches {
7123 set start [lindex $match 0]
7124 set end [lindex $match 1]
7125 if {$start > $end} continue
7126 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
7127 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
7128 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
7129 [expr {$x0+$xlen+2}] $y1 \
7130 -outline {} -tags [list match$l matches] -fill $foundbgcolor]
7131 $canv lower $t
7132 if {$row == $selectedline} {
7133 $canv raise $t secsel
7134 }
7135 }
7136}
7137
7138proc unmarkmatches {} {
7139 global markingmatches
7140
7141 allcanvs delete matches
7142 set markingmatches 0
7143 stopfinding
7144}
7145
7146proc selcanvline {w x y} {
7147 global canv canvy0 ctext linespc
7148 global rowtextx
7149 set ymax [lindex [$canv cget -scrollregion] 3]
7150 if {$ymax == {}} return
7151 set yfrac [lindex [$canv yview] 0]
7152 set y [expr {$y + $yfrac * $ymax}]
7153 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
7154 if {$l < 0} {
7155 set l 0
7156 }
7157 if {$w eq $canv} {
7158 set xmax [lindex [$canv cget -scrollregion] 2]
7159 set xleft [expr {[lindex [$canv xview] 0] * $xmax}]
7160 if {![info exists rowtextx($l)] || $xleft + $x < $rowtextx($l)} return
7161 }
7162 unmarkmatches
7163 selectline $l 1
7164}
7165
7166proc commit_descriptor {p} {
7167 global commitinfo
7168 if {![info exists commitinfo($p)]} {
7169 getcommit $p
7170 }
7171 set l "..."
7172 if {[llength $commitinfo($p)] > 1} {
7173 set l [lindex $commitinfo($p) 0]
7174 }
7175 return "$p ($l)\n"
7176}
7177
7178# append some text to the ctext widget, and make any SHA1 ID
7179# that we know about be a clickable link.
7180# Also look for URLs of the form "http[s]://..." and make them web links.
7181proc appendwithlinks {text tags} {
7182 global ctext linknum curview
7183 global hashlength
7184
7185 set start [$ctext index "end - 1c"]
7186 $ctext insert end $text $tags
7187 set links [regexp -indices -all -inline [string map "@@ $hashlength" {(?:\m|-g)[0-9a-f]{6,@@}\M}] $text]
7188 foreach l $links {
7189 set s [lindex $l 0]
7190 set e [lindex $l 1]
7191 set linkid [string range $text $s $e]
7192 incr e
7193 $ctext tag delete link$linknum
7194 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
7195 setlink $linkid link$linknum
7196 incr linknum
7197 }
7198 set wlinks [regexp -indices -all -inline -line \
7199 {https?://[^[:space:]]+} $text]
7200 foreach l $wlinks {
7201 set s2 [lindex $l 0]
7202 set e2 [lindex $l 1]
7203 set url [string range $text $s2 $e2]
7204 incr e2
7205 $ctext tag delete link$linknum
7206 $ctext tag add link$linknum "$start + $s2 c" "$start + $e2 c"
7207 setwlink $url link$linknum
7208 incr linknum
7209 }
7210}
7211
7212proc setlink {id lk} {
7213 global curview ctext pendinglinks
7214 global linkfgcolor
7215 global hashlength
7216
7217 if {[string range $id 0 1] eq "-g"} {
7218 set id [string range $id 2 end]
7219 }
7220
7221 set known 0
7222 if {[string length $id] < $hashlength} {
7223 set matches [longid $id]
7224 if {[llength $matches] > 0} {
7225 if {[llength $matches] > 1} return
7226 set known 1
7227 set id [lindex $matches 0]
7228 }
7229 } else {
7230 set known [commitinview $id $curview]
7231 }
7232 if {$known} {
7233 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7234 $ctext tag bind $lk <1> [list selbyid $id]
7235 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7236 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7237 } else {
7238 lappend pendinglinks($id) $lk
7239 interestedin $id {makelink %P}
7240 }
7241}
7242
7243proc setwlink {url lk} {
7244 global ctext
7245 global linkfgcolor
7246 global web_browser
7247
7248 if {$web_browser eq {}} return
7249 $ctext tag conf $lk -foreground $linkfgcolor -underline 1
7250 $ctext tag bind $lk <1> [list browseweb $url]
7251 $ctext tag bind $lk <Enter> {linkcursor %W 1}
7252 $ctext tag bind $lk <Leave> {linkcursor %W -1}
7253}
7254
7255proc appendshortlink {id {pre {}} {post {}}} {
7256 global ctext linknum
7257
7258 $ctext insert end $pre
7259 $ctext tag delete link$linknum
7260 $ctext insert end [string range $id 0 7] link$linknum
7261 $ctext insert end $post
7262 setlink $id link$linknum
7263 incr linknum
7264}
7265
7266proc makelink {id} {
7267 global pendinglinks
7268
7269 if {![info exists pendinglinks($id)]} return
7270 foreach lk $pendinglinks($id) {
7271 setlink $id $lk
7272 }
7273 unset pendinglinks($id)
7274}
7275
7276proc linkcursor {w inc} {
7277 global linkentercount curtextcursor
7278
7279 if {[incr linkentercount $inc] > 0} {
7280 $w configure -cursor hand2
7281 } else {
7282 $w configure -cursor $curtextcursor
7283 if {$linkentercount < 0} {
7284 set linkentercount 0
7285 }
7286 }
7287}
7288
7289proc browseweb {url} {
7290 global web_browser
7291
7292 if {$web_browser eq {}} return
7293 # Use concat here in case $web_browser is a command plus some arguments
7294 if {[catch {safe_exec_redirect [concat $web_browser [list $url]] [list &]} err]} {
7295 error_popup "[mc "Error starting web browser:"] $err"
7296 }
7297}
7298
7299proc viewnextline {dir} {
7300 global canv linespc
7301
7302 $canv delete hover
7303 set ymax [lindex [$canv cget -scrollregion] 3]
7304 set wnow [$canv yview]
7305 set wtop [expr {[lindex $wnow 0] * $ymax}]
7306 set newtop [expr {$wtop + $dir * $linespc}]
7307 if {$newtop < 0} {
7308 set newtop 0
7309 } elseif {$newtop > $ymax} {
7310 set newtop $ymax
7311 }
7312 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7313}
7314
7315# add a list of tag or branch names at position pos
7316# returns the number of names inserted
7317proc appendrefs {pos ids var} {
7318 global ctext linknum curview $var maxrefs visiblerefs mainheadid
7319
7320 if {[catch {$ctext index $pos}]} {
7321 return 0
7322 }
7323 $ctext conf -state normal
7324 $ctext delete $pos "$pos lineend"
7325 set tags {}
7326 foreach id $ids {
7327 foreach tag [set $var\($id\)] {
7328 lappend tags [list $tag $id]
7329 }
7330 }
7331
7332 set sep {}
7333 set tags [lsort -index 0 -decreasing $tags]
7334 set nutags 0
7335
7336 if {[llength $tags] > $maxrefs} {
7337 # If we are displaying heads, and there are too many,
7338 # see if there are some important heads to display.
7339 # Currently that are the current head and heads listed in $visiblerefs option
7340 set itags {}
7341 if {$var eq "idheads"} {
7342 set utags {}
7343 foreach ti $tags {
7344 set hname [lindex $ti 0]
7345 set id [lindex $ti 1]
7346 if {([lsearch -exact $visiblerefs $hname] != -1 || $id eq $mainheadid) &&
7347 [llength $itags] < $maxrefs} {
7348 lappend itags $ti
7349 } else {
7350 lappend utags $ti
7351 }
7352 }
7353 set tags $utags
7354 }
7355 if {$itags ne {}} {
7356 set str [mc "and many more"]
7357 set sep " "
7358 } else {
7359 set str [mc "many"]
7360 }
7361 $ctext insert $pos "$str ([llength $tags])"
7362 set nutags [llength $tags]
7363 set tags $itags
7364 }
7365
7366 foreach ti $tags {
7367 set id [lindex $ti 1]
7368 set lk link$linknum
7369 incr linknum
7370 $ctext tag delete $lk
7371 $ctext insert $pos $sep
7372 $ctext insert $pos [lindex $ti 0] $lk
7373 setlink $id $lk
7374 set sep ", "
7375 }
7376 $ctext tag add wwrap "$pos linestart" "$pos lineend"
7377 $ctext conf -state disabled
7378 return [expr {[llength $tags] + $nutags}]
7379}
7380
7381# called when we have finished computing the nearby tags
7382proc dispneartags {delay} {
7383 global selectedline currentid showneartags tagphase
7384
7385 if {$selectedline eq {} || !$showneartags} return
7386 after cancel dispnexttag
7387 if {$delay} {
7388 after 200 dispnexttag
7389 set tagphase -1
7390 } else {
7391 after idle dispnexttag
7392 set tagphase 0
7393 }
7394}
7395
7396proc dispnexttag {} {
7397 global selectedline currentid showneartags tagphase ctext
7398
7399 if {$selectedline eq {} || !$showneartags} return
7400 switch -- $tagphase {
7401 0 {
7402 set dtags [desctags $currentid]
7403 if {$dtags ne {}} {
7404 appendrefs precedes $dtags idtags
7405 }
7406 }
7407 1 {
7408 set atags [anctags $currentid]
7409 if {$atags ne {}} {
7410 appendrefs follows $atags idtags
7411 }
7412 }
7413 2 {
7414 set dheads [descheads $currentid]
7415 if {$dheads ne {}} {
7416 if {[appendrefs branch $dheads idheads] > 1
7417 && [$ctext get "branch -3c"] eq "h"} {
7418 # turn "Branch" into "Branches"
7419 $ctext conf -state normal
7420 $ctext insert "branch -2c" "es"
7421 $ctext conf -state disabled
7422 }
7423 }
7424 }
7425 }
7426 if {[incr tagphase] <= 2} {
7427 after idle dispnexttag
7428 }
7429}
7430
7431proc make_secsel {id} {
7432 global linehtag linentag linedtag canv canv2 canv3
7433
7434 if {![info exists linehtag($id)]} return
7435 $canv delete secsel
7436 set t [eval $canv create rect [$canv bbox $linehtag($id)] -outline {{}} \
7437 -tags secsel -fill [$canv cget -selectbackground]]
7438 $canv lower $t
7439 $canv2 delete secsel
7440 set t [eval $canv2 create rect [$canv2 bbox $linentag($id)] -outline {{}} \
7441 -tags secsel -fill [$canv2 cget -selectbackground]]
7442 $canv2 lower $t
7443 $canv3 delete secsel
7444 set t [eval $canv3 create rect [$canv3 bbox $linedtag($id)] -outline {{}} \
7445 -tags secsel -fill [$canv3 cget -selectbackground]]
7446 $canv3 lower $t
7447}
7448
7449proc make_idmark {id} {
7450 global linehtag canv fgcolor
7451
7452 if {![info exists linehtag($id)]} return
7453 $canv delete markid
7454 set t [eval $canv create rect [$canv bbox $linehtag($id)] \
7455 -tags markid -outline $fgcolor]
7456 $canv raise $t
7457}
7458
7459proc selectline {l isnew {desired_loc {}} {switch_to_patch 0}} {
7460 global canv ctext commitinfo selectedline
7461 global canvy0 linespc parents children curview
7462 global currentid sha1entry
7463 global commentend idtags linknum
7464 global mergemax numcommits pending_select
7465 global cmitmode showneartags allcommits
7466 global targetrow targetid lastscrollrows
7467 global autocopy autoselect autosellen jump_to_here
7468 global vinlinediff
7469
7470 unset -nocomplain pending_select
7471 $canv delete hover
7472 normalline
7473 unsel_reflist
7474 stopfinding
7475 if {$l < 0 || $l >= $numcommits} return
7476 set id [commitonrow $l]
7477 set targetid $id
7478 set targetrow $l
7479 set selectedline $l
7480 set currentid $id
7481 if {$lastscrollrows < $numcommits} {
7482 setcanvscroll
7483 }
7484
7485 if {$cmitmode ne "patch" && $switch_to_patch} {
7486 set cmitmode "patch"
7487 }
7488
7489 set y [expr {$canvy0 + $l * $linespc}]
7490 set ymax [lindex [$canv cget -scrollregion] 3]
7491 set ytop [expr {$y - $linespc - 1}]
7492 set ybot [expr {$y + $linespc + 1}]
7493 set wnow [$canv yview]
7494 set wtop [expr {[lindex $wnow 0] * $ymax}]
7495 set wbot [expr {[lindex $wnow 1] * $ymax}]
7496 set wh [expr {$wbot - $wtop}]
7497 set newtop $wtop
7498 if {$ytop < $wtop} {
7499 if {$ybot < $wtop} {
7500 set newtop [expr {$y - $wh / 2.0}]
7501 } else {
7502 set newtop $ytop
7503 if {$newtop > $wtop - $linespc} {
7504 set newtop [expr {$wtop - $linespc}]
7505 }
7506 }
7507 } elseif {$ybot > $wbot} {
7508 if {$ytop > $wbot} {
7509 set newtop [expr {$y - $wh / 2.0}]
7510 } else {
7511 set newtop [expr {$ybot - $wh}]
7512 if {$newtop < $wtop + $linespc} {
7513 set newtop [expr {$wtop + $linespc}]
7514 }
7515 }
7516 }
7517 if {$newtop != $wtop} {
7518 if {$newtop < 0} {
7519 set newtop 0
7520 }
7521 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
7522 drawvisible
7523 }
7524
7525 make_secsel $id
7526
7527 if {$isnew} {
7528 addtohistory [list selbyid $id 0] savecmitpos
7529 }
7530
7531 $sha1entry delete 0 end
7532 $sha1entry insert 0 $id
7533 if {$autoselect && [haveselectionclipboard]} {
7534 $sha1entry selection range 0 $autosellen
7535 }
7536 if {$autocopy} {
7537 clipboard clear
7538 clipboard append [string range $id 0 [expr $autosellen - 1]]
7539 }
7540 rhighlight_sel $id
7541
7542 $ctext conf -state normal
7543 clear_ctext
7544 set linknum 0
7545 if {![info exists commitinfo($id)]} {
7546 getcommit $id
7547 }
7548 set info $commitinfo($id)
7549 set date [formatdate [lindex $info 2]]
7550 $ctext insert end "[mc "Author"]: [lindex $info 1] $date\n"
7551 set date [formatdate [lindex $info 4]]
7552 $ctext insert end "[mc "Committer"]: [lindex $info 3] $date\n"
7553 if {[info exists idtags($id)]} {
7554 $ctext insert end [mc "Tags:"]
7555 foreach tag $idtags($id) {
7556 $ctext insert end " $tag"
7557 }
7558 $ctext insert end "\n"
7559 }
7560
7561 set headers {}
7562 set olds $parents($curview,$id)
7563 if {[llength $olds] > 1} {
7564 set np 0
7565 foreach p $olds {
7566 if {$np >= $mergemax} {
7567 set tag mmax
7568 } else {
7569 set tag m$np
7570 }
7571 $ctext insert end "[mc "Parent"]: " $tag
7572 appendwithlinks [commit_descriptor $p] {}
7573 incr np
7574 }
7575 } else {
7576 foreach p $olds {
7577 append headers "[mc "Parent"]: [commit_descriptor $p]"
7578 }
7579 }
7580
7581 foreach c $children($curview,$id) {
7582 append headers "[mc "Child"]: [commit_descriptor $c]"
7583 }
7584
7585 # make anything that looks like a SHA1 ID be a clickable link
7586 appendwithlinks $headers {}
7587 if {$showneartags} {
7588 if {![info exists allcommits]} {
7589 getallcommits
7590 }
7591 $ctext insert end "[mc "Branch"]: "
7592 $ctext mark set branch "end -1c"
7593 $ctext mark gravity branch left
7594 $ctext insert end "\n[mc "Follows"]: "
7595 $ctext mark set follows "end -1c"
7596 $ctext mark gravity follows left
7597 $ctext insert end "\n[mc "Precedes"]: "
7598 $ctext mark set precedes "end -1c"
7599 $ctext mark gravity precedes left
7600 $ctext insert end "\n"
7601 dispneartags 1
7602 }
7603 $ctext insert end "\n"
7604 set comment [lindex $info 5]
7605 if {[string first "\r" $comment] >= 0} {
7606 set comment [string map {"\r" "\n "} $comment]
7607 }
7608 appendwithlinks $comment {comment}
7609
7610 $ctext tag remove found 1.0 end
7611 $ctext conf -state disabled
7612 set commentend [$ctext index "end - 1c"]
7613
7614 set jump_to_here $desired_loc
7615 init_flist [mc "Comments"]
7616 if {$cmitmode eq "tree"} {
7617 gettree $id
7618 } elseif {$vinlinediff($curview) == 1} {
7619 showinlinediff $id
7620 } elseif {[llength $olds] <= 1} {
7621 startdiff $id
7622 } else {
7623 mergediff $id
7624 }
7625}
7626
7627proc selfirstline {} {
7628 unmarkmatches
7629 selectline 0 1
7630}
7631
7632proc sellastline {} {
7633 global numcommits
7634 unmarkmatches
7635 set l [expr {$numcommits - 1}]
7636 selectline $l 1
7637}
7638
7639proc selnextline {dir} {
7640 global selectedline
7641 focus .
7642 if {$selectedline eq {}} return
7643 set l [expr {$selectedline + $dir}]
7644 unmarkmatches
7645 selectline $l 1
7646}
7647
7648proc selnextpage {dir} {
7649 global canv linespc selectedline numcommits
7650
7651 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
7652 if {$lpp < 1} {
7653 set lpp 1
7654 }
7655 allcanvs yview scroll [expr {$dir * $lpp}] units
7656 drawvisible
7657 if {$selectedline eq {}} return
7658 set l [expr {$selectedline + $dir * $lpp}]
7659 if {$l < 0} {
7660 set l 0
7661 } elseif {$l >= $numcommits} {
7662 set l [expr $numcommits - 1]
7663 }
7664 unmarkmatches
7665 selectline $l 1
7666}
7667
7668proc unselectline {} {
7669 global selectedline currentid
7670
7671 set selectedline {}
7672 unset -nocomplain currentid
7673 allcanvs delete secsel
7674 rhighlight_none
7675}
7676
7677proc reselectline {} {
7678 global selectedline
7679
7680 if {$selectedline ne {}} {
7681 selectline $selectedline 0
7682 }
7683}
7684
7685proc addtohistory {cmd {saveproc {}}} {
7686 global history historyindex curview
7687
7688 unset_posvars
7689 save_position
7690 set elt [list $curview $cmd $saveproc {}]
7691 if {$historyindex > 0
7692 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
7693 return
7694 }
7695
7696 if {$historyindex < [llength $history]} {
7697 set history [lreplace $history $historyindex end $elt]
7698 } else {
7699 lappend history $elt
7700 }
7701 incr historyindex
7702 if {$historyindex > 1} {
7703 .tf.bar.leftbut conf -state normal
7704 } else {
7705 .tf.bar.leftbut conf -state disabled
7706 }
7707 .tf.bar.rightbut conf -state disabled
7708}
7709
7710# save the scrolling position of the diff display pane
7711proc save_position {} {
7712 global historyindex history
7713
7714 if {$historyindex < 1} return
7715 set hi [expr {$historyindex - 1}]
7716 set fn [lindex $history $hi 2]
7717 if {$fn ne {}} {
7718 lset history $hi 3 [eval $fn]
7719 }
7720}
7721
7722proc unset_posvars {} {
7723 global last_posvars
7724
7725 if {[info exists last_posvars]} {
7726 foreach {var val} $last_posvars {
7727 global $var
7728 unset -nocomplain $var
7729 }
7730 unset last_posvars
7731 }
7732}
7733
7734proc godo {elt} {
7735 global curview last_posvars
7736
7737 set view [lindex $elt 0]
7738 set cmd [lindex $elt 1]
7739 set pv [lindex $elt 3]
7740 if {$curview != $view} {
7741 showview $view
7742 }
7743 unset_posvars
7744 foreach {var val} $pv {
7745 global $var
7746 set $var $val
7747 }
7748 set last_posvars $pv
7749 eval $cmd
7750}
7751
7752proc goback {} {
7753 global history historyindex
7754 focus .
7755
7756 if {$historyindex > 1} {
7757 save_position
7758 incr historyindex -1
7759 godo [lindex $history [expr {$historyindex - 1}]]
7760 .tf.bar.rightbut conf -state normal
7761 }
7762 if {$historyindex <= 1} {
7763 .tf.bar.leftbut conf -state disabled
7764 }
7765}
7766
7767proc goforw {} {
7768 global history historyindex
7769 focus .
7770
7771 if {$historyindex < [llength $history]} {
7772 save_position
7773 set cmd [lindex $history $historyindex]
7774 incr historyindex
7775 godo $cmd
7776 .tf.bar.leftbut conf -state normal
7777 }
7778 if {$historyindex >= [llength $history]} {
7779 .tf.bar.rightbut conf -state disabled
7780 }
7781}
7782
7783proc go_to_parent {i} {
7784 global parents curview targetid
7785 set ps $parents($curview,$targetid)
7786 if {[llength $ps] >= $i} {
7787 selbyid [lindex $ps [expr $i - 1]]
7788 }
7789}
7790
7791proc gettree {id} {
7792 global treefilelist treeidlist diffids diffmergeid treepending
7793 global nullid nullid2
7794
7795 set diffids $id
7796 unset -nocomplain diffmergeid
7797 if {![info exists treefilelist($id)]} {
7798 if {![info exists treepending]} {
7799 if {$id eq $nullid} {
7800 set cmd [list git ls-files]
7801 } elseif {$id eq $nullid2} {
7802 set cmd [list git ls-files --stage -t]
7803 } else {
7804 set cmd [list git ls-tree -r $id]
7805 }
7806 if {[catch {set gtf [safe_open_command $cmd]}]} {
7807 return
7808 }
7809 set treepending $id
7810 set treefilelist($id) {}
7811 set treeidlist($id) {}
7812 fconfigure $gtf -blocking 0 -translation binary
7813 filerun $gtf [list gettreeline $gtf $id]
7814 }
7815 } else {
7816 setfilelist $id
7817 }
7818}
7819
7820proc gettreeline {gtf id} {
7821 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
7822
7823 set nl 0
7824 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
7825 if {$diffids eq $nullid} {
7826 set fname $line
7827 } else {
7828 set i [string first "\t" $line]
7829 if {$i < 0} continue
7830 set fname [string range $line [expr {$i+1}] end]
7831 set line [string range $line 0 [expr {$i-1}]]
7832 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
7833 set sha1 [lindex $line 2]
7834 lappend treeidlist($id) $sha1
7835 }
7836 if {[string index $fname 0] eq "\""} {
7837 set fname [lindex $fname 0]
7838 }
7839 set fname [convertfrom utf-8 $fname]
7840 lappend treefilelist($id) $fname
7841 }
7842 if {![eof $gtf]} {
7843 return [expr {$nl >= 1000? 2: 1}]
7844 }
7845 close $gtf
7846 unset treepending
7847 if {$cmitmode ne "tree"} {
7848 if {![info exists diffmergeid]} {
7849 gettreediffs $diffids
7850 }
7851 } elseif {$id ne $diffids} {
7852 gettree $diffids
7853 } else {
7854 setfilelist $id
7855 }
7856 return 0
7857}
7858
7859proc showfile {f} {
7860 global treefilelist treeidlist diffids nullid nullid2
7861 global ctext_file_names ctext_file_lines
7862 global ctext commentend
7863
7864 set i [lsearch -exact $treefilelist($diffids) $f]
7865 if {$i < 0} {
7866 puts "oops, $f not in list for id $diffids"
7867 return
7868 }
7869 if {$diffids eq $nullid} {
7870 if {[catch {set bf [safe_open_file $f r]} err]} {
7871 puts "oops, can't read $f: $err"
7872 return
7873 }
7874 } else {
7875 set blob [lindex $treeidlist($diffids) $i]
7876 if {[catch {set bf [safe_open_command [concat git cat-file blob $blob]]} err]} {
7877 puts "oops, error reading blob $blob: $err"
7878 return
7879 }
7880 }
7881 fconfigure $bf -blocking 0 -encoding [get_path_encoding $f]
7882 filerun $bf [list getblobline $bf $diffids]
7883 $ctext config -state normal
7884 clear_ctext $commentend
7885 lappend ctext_file_names $f
7886 lappend ctext_file_lines [lindex [split $commentend "."] 0]
7887 $ctext insert end "\n"
7888 $ctext insert end "$f\n" filesep
7889 $ctext config -state disabled
7890 $ctext yview $commentend
7891 settabs 0
7892}
7893
7894proc getblobline {bf id} {
7895 global diffids cmitmode ctext
7896
7897 if {$id ne $diffids || $cmitmode ne "tree"} {
7898 catch {close $bf}
7899 return 0
7900 }
7901 $ctext config -state normal
7902 set nl 0
7903 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
7904 $ctext insert end "$line\n"
7905 }
7906 if {[eof $bf]} {
7907 global jump_to_here ctext_file_names commentend
7908
7909 # delete last newline
7910 $ctext delete "end - 2c" "end - 1c"
7911 close $bf
7912 if {$jump_to_here ne {} &&
7913 [lindex $jump_to_here 0] eq [lindex $ctext_file_names 0]} {
7914 set lnum [expr {[lindex $jump_to_here 1] +
7915 [lindex [split $commentend .] 0]}]
7916 mark_ctext_line $lnum
7917 }
7918 $ctext config -state disabled
7919 return 0
7920 }
7921 $ctext config -state disabled
7922 return [expr {$nl >= 1000? 2: 1}]
7923}
7924
7925proc mark_ctext_line {lnum} {
7926 global ctext markbgcolor
7927
7928 $ctext tag delete omark
7929 $ctext tag add omark $lnum.0 "$lnum.0 + 1 line"
7930 $ctext tag conf omark -background $markbgcolor
7931 $ctext see $lnum.0
7932}
7933
7934proc mergediff {id} {
7935 global diffmergeid
7936 global diffids treediffs
7937 global parents curview
7938
7939 set diffmergeid $id
7940 set diffids $id
7941 set treediffs($id) {}
7942 set np [llength $parents($curview,$id)]
7943 settabs $np
7944 getblobdiffs $id
7945}
7946
7947proc startdiff {ids} {
7948 global treediffs diffids treepending diffmergeid nullid nullid2
7949
7950 settabs 1
7951 set diffids $ids
7952 unset -nocomplain diffmergeid
7953 if {![info exists treediffs($ids)] ||
7954 [lsearch -exact $ids $nullid] >= 0 ||
7955 [lsearch -exact $ids $nullid2] >= 0} {
7956 if {![info exists treepending]} {
7957 gettreediffs $ids
7958 }
7959 } else {
7960 addtocflist $ids
7961 }
7962}
7963
7964proc showinlinediff {ids} {
7965 global commitinfo commitdata ctext
7966 global treediffs
7967
7968 set info $commitinfo($ids)
7969 set diff [lindex $info 7]
7970 set difflines [split $diff "\n"]
7971
7972 initblobdiffvars
7973 set treediff {}
7974
7975 set inhdr 0
7976 foreach line $difflines {
7977 if {![string compare -length 5 "diff " $line]} {
7978 set inhdr 1
7979 } elseif {$inhdr && ![string compare -length 4 "+++ " $line]} {
7980 # offset also accounts for the b/ prefix
7981 lappend treediff [string range $line 6 end]
7982 set inhdr 0
7983 }
7984 }
7985
7986 set treediffs($ids) $treediff
7987 add_flist $treediff
7988
7989 $ctext conf -state normal
7990 foreach line $difflines {
7991 parseblobdiffline $ids $line
7992 }
7993 maybe_scroll_ctext 1
7994 $ctext conf -state disabled
7995}
7996
7997# If the filename (name) is under any of the passed filter paths
7998# then return true to include the file in the listing.
7999proc path_filter {filter name} {
8000 set worktree [gitworktree]
8001 foreach p $filter {
8002 set fq_p [file normalize $p]
8003 set fq_n [file normalize [file join $worktree $name]]
8004 if {[string match [file normalize $fq_p]* $fq_n]} {
8005 return 1
8006 }
8007 }
8008 return 0
8009}
8010
8011proc addtocflist {ids} {
8012 global treediffs
8013
8014 add_flist $treediffs($ids)
8015 getblobdiffs $ids
8016}
8017
8018proc diffcmd {ids flags} {
8019 global log_showroot nullid nullid2
8020
8021 set i [lsearch -exact $ids $nullid]
8022 set j [lsearch -exact $ids $nullid2]
8023 if {$i >= 0} {
8024 if {[llength $ids] > 1 && $j < 0} {
8025 # comparing working directory with some specific revision
8026 set cmd [concat git diff-index $flags]
8027 if {$i == 0} {
8028 lappend cmd -R [lindex $ids 1]
8029 } else {
8030 lappend cmd [lindex $ids 0]
8031 }
8032 } else {
8033 # comparing working directory with index
8034 set cmd [concat git diff-files $flags]
8035 if {$j == 1} {
8036 lappend cmd -R
8037 }
8038 }
8039 } elseif {$j >= 0} {
8040 set flags "$flags --ignore-submodules=dirty"
8041 set cmd [concat git diff-index --cached $flags]
8042 if {[llength $ids] > 1} {
8043 # comparing index with specific revision
8044 if {$j == 0} {
8045 lappend cmd -R [lindex $ids 1]
8046 } else {
8047 lappend cmd [lindex $ids 0]
8048 }
8049 } else {
8050 # comparing index with HEAD
8051 lappend cmd HEAD
8052 }
8053 } else {
8054 if {$log_showroot} {
8055 lappend flags --root
8056 }
8057 set cmd [concat git diff-tree -r $flags $ids]
8058 }
8059 return $cmd
8060}
8061
8062proc gettreediffs {ids} {
8063 global treediff treepending limitdiffs vfilelimit curview
8064
8065 set cmd [diffcmd $ids {--no-commit-id}]
8066 if {$limitdiffs && $vfilelimit($curview) ne {}} {
8067 set cmd [concat $cmd -- $vfilelimit($curview)]
8068 }
8069 if {[catch {set gdtf [safe_open_command $cmd]}]} return
8070
8071 set treepending $ids
8072 set treediff {}
8073 fconfigure $gdtf -blocking 0 -translation binary
8074 filerun $gdtf [list gettreediffline $gdtf $ids]
8075}
8076
8077proc gettreediffline {gdtf ids} {
8078 global treediff treediffs treepending diffids diffmergeid
8079 global cmitmode vfilelimit curview limitdiffs perfile_attrs
8080
8081 set nr 0
8082 set sublist {}
8083 set max 1000
8084 if {$perfile_attrs} {
8085 # cache_gitattr is slow, and even slower on win32 where we
8086 # have to invoke it for only about 30 paths at a time
8087 set max 500
8088 if {[tk windowingsystem] == "win32"} {
8089 set max 120
8090 }
8091 }
8092 while {[incr nr] <= $max && [gets $gdtf line] >= 0} {
8093 set i [string first "\t" $line]
8094 if {$i >= 0} {
8095 set file [string range $line [expr {$i+1}] end]
8096 if {[string index $file 0] eq "\""} {
8097 set file [lindex $file 0]
8098 }
8099 set file [convertfrom utf-8 $file]
8100 if {$file ne [lindex $treediff end]} {
8101 lappend treediff $file
8102 lappend sublist $file
8103 }
8104 }
8105 }
8106 if {$perfile_attrs} {
8107 cache_gitattr encoding $sublist
8108 }
8109 if {![eof $gdtf]} {
8110 return [expr {$nr >= $max? 2: 1}]
8111 }
8112 close $gdtf
8113 set treediffs($ids) $treediff
8114 unset treepending
8115 if {$cmitmode eq "tree" && [llength $diffids] == 1} {
8116 gettree $diffids
8117 } elseif {$ids != $diffids} {
8118 if {![info exists diffmergeid]} {
8119 gettreediffs $diffids
8120 }
8121 } else {
8122 addtocflist $ids
8123 }
8124 return 0
8125}
8126
8127# empty string or positive integer
8128proc diffcontextvalidate {v} {
8129 return [regexp {^(|[1-9][0-9]*)$} $v]
8130}
8131
8132proc diffcontextchange {n1 n2 op} {
8133 global diffcontextstring diffcontext
8134
8135 if {[string is integer -strict $diffcontextstring]} {
8136 if {$diffcontextstring >= 0} {
8137 set diffcontext $diffcontextstring
8138 reselectline
8139 }
8140 }
8141}
8142
8143proc changeignorespace {} {
8144 reselectline
8145}
8146
8147proc changeworddiff {name ix op} {
8148 reselectline
8149}
8150
8151proc initblobdiffvars {} {
8152 global diffencoding targetline diffnparents
8153 global diffinhdr currdiffsubmod diffseehere
8154 set targetline {}
8155 set diffnparents 0
8156 set diffinhdr 0
8157 set diffencoding [get_path_encoding {}]
8158 set currdiffsubmod ""
8159 set diffseehere -1
8160}
8161
8162proc getblobdiffs {ids} {
8163 global blobdifffd diffids env
8164 global treediffs
8165 global diffcontext
8166 global ignorespace
8167 global worddiff
8168 global limitdiffs vfilelimit curview
8169
8170 set cmd [diffcmd $ids "-p --textconv --submodule -C --cc --no-commit-id -U$diffcontext"]
8171 if {$ignorespace} {
8172 append cmd " -w"
8173 }
8174 if {$worddiff ne [mc "Line diff"]} {
8175 append cmd " --word-diff=porcelain"
8176 }
8177 if {$limitdiffs && $vfilelimit($curview) ne {}} {
8178 set cmd [concat $cmd -- $vfilelimit($curview)]
8179 }
8180 if {[catch {set bdf [safe_open_command $cmd]} err]} {
8181 error_popup [mc "Error getting diffs: %s" $err]
8182 return
8183 }
8184 fconfigure $bdf -blocking 0 -translation binary
8185 set blobdifffd($ids) $bdf
8186 initblobdiffvars
8187 filerun $bdf [list getblobdiffline $bdf $diffids]
8188}
8189
8190proc savecmitpos {} {
8191 global ctext cmitmode
8192
8193 if {$cmitmode eq "tree"} {
8194 return {}
8195 }
8196 return [list target_scrollpos [$ctext index @0,0]]
8197}
8198
8199proc savectextpos {} {
8200 global ctext
8201
8202 return [list target_scrollpos [$ctext index @0,0]]
8203}
8204
8205proc maybe_scroll_ctext {ateof} {
8206 global ctext target_scrollpos
8207
8208 if {![info exists target_scrollpos]} return
8209 if {!$ateof} {
8210 set nlines [expr {[winfo height $ctext]
8211 / [font metrics textfont -linespace]}]
8212 if {[$ctext compare "$target_scrollpos + $nlines lines" <= end]} return
8213 }
8214 $ctext yview $target_scrollpos
8215 unset target_scrollpos
8216}
8217
8218proc setinlist {var i val} {
8219 global $var
8220
8221 while {[llength [set $var]] < $i} {
8222 lappend $var {}
8223 }
8224 if {[llength [set $var]] == $i} {
8225 lappend $var $val
8226 } else {
8227 lset $var $i $val
8228 }
8229}
8230
8231proc makediffhdr {fname ids} {
8232 global ctext curdiffstart treediffs diffencoding
8233 global ctext_file_names jump_to_here targetline diffline
8234
8235 set fname [convertfrom utf-8 $fname]
8236 set diffencoding [get_path_encoding $fname]
8237 set i [lsearch -exact $treediffs($ids) $fname]
8238 if {$i >= 0} {
8239 setinlist difffilestart $i $curdiffstart
8240 }
8241 lset ctext_file_names end $fname
8242 set l [expr {(78 - [string length $fname]) / 2}]
8243 set pad [string range "----------------------------------------" 1 $l]
8244 $ctext insert $curdiffstart "$pad $fname $pad" filesep
8245 set targetline {}
8246 if {$jump_to_here ne {} && [lindex $jump_to_here 0] eq $fname} {
8247 set targetline [lindex $jump_to_here 1]
8248 }
8249 set diffline 0
8250}
8251
8252proc blobdiffmaybeseehere {ateof} {
8253 global diffseehere
8254 if {$diffseehere >= 0} {
8255 mark_ctext_line [lindex [split $diffseehere .] 0]
8256 }
8257 maybe_scroll_ctext $ateof
8258}
8259
8260proc getblobdiffline {bdf ids} {
8261 global diffids blobdifffd
8262 global ctext
8263
8264 set nr 0
8265 $ctext conf -state normal
8266 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
8267 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
8268 # Older diff read. Abort it.
8269 catch {close $bdf}
8270 if {$ids != $diffids} {
8271 array unset blobdifffd $ids
8272 }
8273 return 0
8274 }
8275 parseblobdiffline $ids $line
8276 }
8277 $ctext conf -state disabled
8278 blobdiffmaybeseehere [eof $bdf]
8279 if {[eof $bdf]} {
8280 catch {close $bdf}
8281 array unset blobdifffd $ids
8282 return 0
8283 }
8284 return [expr {$nr >= 1000? 2: 1}]
8285}
8286
8287proc parseblobdiffline {ids line} {
8288 global ctext curdiffstart
8289 global diffnexthead diffnextnote difffilestart
8290 global ctext_file_names ctext_file_lines
8291 global diffinhdr treediffs mergemax diffnparents
8292 global diffencoding jump_to_here targetline diffline currdiffsubmod
8293 global worddiff diffseehere
8294
8295 if {![string compare -length 5 "diff " $line]} {
8296 if {![regexp {^diff (--cc|--git) } $line m type]} {
8297 set line [convertfrom utf-8 $line]
8298 $ctext insert end "$line\n" hunksep
8299 continue
8300 }
8301 # start of a new file
8302 set diffinhdr 1
8303 set currdiffsubmod ""
8304
8305 $ctext insert end "\n"
8306 set curdiffstart [$ctext index "end - 1c"]
8307 lappend ctext_file_names ""
8308 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8309 $ctext insert end "\n" filesep
8310
8311 if {$type eq "--cc"} {
8312 # start of a new file in a merge diff
8313 set fname [string range $line 10 end]
8314 if {[lsearch -exact $treediffs($ids) $fname] < 0} {
8315 lappend treediffs($ids) $fname
8316 add_flist [list $fname]
8317 }
8318
8319 } else {
8320 set line [string range $line 11 end]
8321 # If the name hasn't changed the length will be odd,
8322 # the middle char will be a space, and the two bits either
8323 # side will be a/name and b/name, or "a/name" and "b/name".
8324 # If the name has changed we'll get "rename from" and
8325 # "rename to" or "copy from" and "copy to" lines following
8326 # this, and we'll use them to get the filenames.
8327 # This complexity is necessary because spaces in the
8328 # filename(s) don't get escaped.
8329 set l [string length $line]
8330 set i [expr {$l / 2}]
8331 if {!(($l & 1) && [string index $line $i] eq " " &&
8332 [string range $line 2 [expr {$i - 1}]] eq \
8333 [string range $line [expr {$i + 3}] end])} {
8334 return
8335 }
8336 # unescape if quoted and chop off the a/ from the front
8337 if {[string index $line 0] eq "\""} {
8338 set fname [string range [lindex $line 0] 2 end]
8339 } else {
8340 set fname [string range $line 2 [expr {$i - 1}]]
8341 }
8342 }
8343 makediffhdr $fname $ids
8344
8345 } elseif {![string compare -length 16 "* Unmerged path " $line]} {
8346 set fname [convertfrom utf-8 [string range $line 16 end]]
8347 $ctext insert end "\n"
8348 set curdiffstart [$ctext index "end - 1c"]
8349 lappend ctext_file_names $fname
8350 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8351 $ctext insert end "$line\n" filesep
8352 set i [lsearch -exact $treediffs($ids) $fname]
8353 if {$i >= 0} {
8354 setinlist difffilestart $i $curdiffstart
8355 }
8356
8357 } elseif {![string compare -length 2 "@@" $line]} {
8358 regexp {^@@+} $line ats
8359 set line [convertfrom $diffencoding $line]
8360 $ctext insert end "$line\n" hunksep
8361 if {[regexp { \+(\d+),\d+ @@} $line m nl]} {
8362 set diffline $nl
8363 }
8364 set diffnparents [expr {[string length $ats] - 1}]
8365 set diffinhdr 0
8366
8367 } elseif {![string compare -length 10 "Submodule " $line]} {
8368 # start of a new submodule
8369 if {[regexp -indices "\[0-9a-f\]+\\.\\." $line nameend]} {
8370 set fname [string range $line 10 [expr [lindex $nameend 0] - 2]]
8371 } else {
8372 set fname [string range $line 10 [expr [string first "contains " $line] - 2]]
8373 }
8374 if {$currdiffsubmod != $fname} {
8375 $ctext insert end "\n"; # Add newline after commit message
8376 }
8377 if {$currdiffsubmod != $fname} {
8378 set curdiffstart [$ctext index "end - 1c"]
8379 lappend ctext_file_names ""
8380 lappend ctext_file_lines [lindex [split $curdiffstart "."] 0]
8381 makediffhdr $fname $ids
8382 set currdiffsubmod $fname
8383 $ctext insert end "\n$line\n" filesep
8384 } else {
8385 $ctext insert end "$line\n" filesep
8386 }
8387 } elseif {$currdiffsubmod != "" && ![string compare -length 3 " >" $line]} {
8388 set line [convertfrom $diffencoding $line]
8389 $ctext insert end "$line\n" dresult
8390 } elseif {$currdiffsubmod != "" && ![string compare -length 3 " <" $line]} {
8391 set line [convertfrom $diffencoding $line]
8392 $ctext insert end "$line\n" d0
8393 } elseif {$diffinhdr} {
8394 if {![string compare -length 12 "rename from " $line]} {
8395 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
8396 if {[string index $fname 0] eq "\""} {
8397 set fname [lindex $fname 0]
8398 }
8399 set fname [convertfrom utf-8 $fname]
8400 set i [lsearch -exact $treediffs($ids) $fname]
8401 if {$i >= 0} {
8402 setinlist difffilestart $i $curdiffstart
8403 }
8404 } elseif {![string compare -length 10 $line "rename to "] ||
8405 ![string compare -length 8 $line "copy to "]} {
8406 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
8407 if {[string index $fname 0] eq "\""} {
8408 set fname [lindex $fname 0]
8409 }
8410 makediffhdr $fname $ids
8411 } elseif {[string compare -length 3 $line "---"] == 0} {
8412 # do nothing
8413 return
8414 } elseif {[string compare -length 3 $line "+++"] == 0} {
8415 set diffinhdr 0
8416 return
8417 }
8418 set line [convertfrom utf-8 $line]
8419 $ctext insert end "$line\n" filesep
8420
8421 } else {
8422 set line [string map {\x1A ^Z} \
8423 [convertfrom $diffencoding $line]]
8424 # parse the prefix - one ' ', '-' or '+' for each parent
8425 set prefix [string range $line 0 [expr {$diffnparents - 1}]]
8426 set tag [expr {$diffnparents > 1? "m": "d"}]
8427 set dowords [expr {$worddiff ne [mc "Line diff"] && $diffnparents == 1}]
8428 set words_pre_markup ""
8429 set words_post_markup ""
8430 if {[string trim $prefix " -+"] eq {}} {
8431 # prefix only has " ", "-" and "+" in it: normal diff line
8432 set num [string first "-" $prefix]
8433 if {$dowords} {
8434 set line [string range $line 1 end]
8435 }
8436 if {$num >= 0} {
8437 # removed line, first parent with line is $num
8438 if {$num >= $mergemax} {
8439 set num "max"
8440 }
8441 if {$dowords && $worddiff eq [mc "Markup words"]} {
8442 $ctext insert end "\[-$line-\]" $tag$num
8443 } else {
8444 $ctext insert end "$line" $tag$num
8445 }
8446 if {!$dowords} {
8447 $ctext insert end "\n" $tag$num
8448 }
8449 } else {
8450 set tags {}
8451 if {[string first "+" $prefix] >= 0} {
8452 # added line
8453 lappend tags ${tag}result
8454 if {$diffnparents > 1} {
8455 set num [string first " " $prefix]
8456 if {$num >= 0} {
8457 if {$num >= $mergemax} {
8458 set num "max"
8459 }
8460 lappend tags m$num
8461 }
8462 }
8463 set words_pre_markup "{+"
8464 set words_post_markup "+}"
8465 }
8466 if {$targetline ne {}} {
8467 if {$diffline == $targetline} {
8468 set diffseehere [$ctext index "end - 1 chars"]
8469 set targetline {}
8470 } else {
8471 incr diffline
8472 }
8473 }
8474 if {$dowords && $worddiff eq [mc "Markup words"]} {
8475 $ctext insert end "$words_pre_markup$line$words_post_markup" $tags
8476 } else {
8477 $ctext insert end "$line" $tags
8478 }
8479 if {!$dowords} {
8480 $ctext insert end "\n" $tags
8481 }
8482 }
8483 } elseif {$dowords && $prefix eq "~"} {
8484 $ctext insert end "\n" {}
8485 } else {
8486 # "\ No newline at end of file",
8487 # or something else we don't recognize
8488 $ctext insert end "$line\n" hunksep
8489 }
8490 }
8491}
8492
8493proc changediffdisp {} {
8494 global ctext diffelide
8495
8496 $ctext tag conf d0 -elide [lindex $diffelide 0]
8497 $ctext tag conf dresult -elide [lindex $diffelide 1]
8498}
8499
8500proc highlightfile {cline} {
8501 global cflist cflist_top
8502
8503 if {![info exists cflist_top]} return
8504
8505 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
8506 $cflist tag add highlight $cline.0 "$cline.0 lineend"
8507 $cflist see $cline.0
8508 set cflist_top $cline
8509}
8510
8511proc highlightfile_for_scrollpos {topidx} {
8512 global cmitmode difffilestart
8513
8514 if {$cmitmode eq "tree"} return
8515 if {![info exists difffilestart]} return
8516
8517 set top [lindex [split $topidx .] 0]
8518 if {$difffilestart eq {} || $top < [lindex $difffilestart 0]} {
8519 highlightfile 0
8520 } else {
8521 highlightfile [expr {[bsearch $difffilestart $top] + 2}]
8522 }
8523}
8524
8525proc prevfile {} {
8526 global difffilestart ctext cmitmode
8527
8528 if {$cmitmode eq "tree"} return
8529 set prev 0.0
8530 set here [$ctext index @0,0]
8531 foreach loc $difffilestart {
8532 if {[$ctext compare $loc >= $here]} {
8533 $ctext yview $prev
8534 return
8535 }
8536 set prev $loc
8537 }
8538 $ctext yview $prev
8539}
8540
8541proc nextfile {} {
8542 global difffilestart ctext cmitmode
8543
8544 if {$cmitmode eq "tree"} return
8545 set here [$ctext index @0,0]
8546 foreach loc $difffilestart {
8547 if {[$ctext compare $loc > $here]} {
8548 $ctext yview $loc
8549 return
8550 }
8551 }
8552}
8553
8554proc clear_ctext {{first 1.0}} {
8555 global ctext smarktop smarkbot
8556 global ctext_file_names ctext_file_lines
8557 global pendinglinks
8558
8559 set l [lindex [split $first .] 0]
8560 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
8561 set smarktop $l
8562 }
8563 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
8564 set smarkbot $l
8565 }
8566 $ctext delete $first end
8567 if {$first eq "1.0"} {
8568 unset -nocomplain pendinglinks
8569 }
8570 set ctext_file_names {}
8571 set ctext_file_lines {}
8572}
8573
8574proc settabs {{firstab {}}} {
8575 global firsttabstop tabstop ctext
8576
8577 if {$firstab ne {}} {
8578 set firsttabstop $firstab
8579 }
8580 set w [font measure textfont "0"]
8581 if {$firsttabstop != 0} {
8582 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
8583 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
8584 } else {
8585 $ctext conf -tabs [expr {$tabstop * $w}]
8586 }
8587}
8588
8589proc incrsearch {name ix op} {
8590 global ctext searchstring searchdirn
8591
8592 if {[catch {$ctext index anchor}]} {
8593 # no anchor set, use start of selection, or of visible area
8594 set sel [$ctext tag ranges sel]
8595 if {$sel ne {}} {
8596 $ctext mark set anchor [lindex $sel 0]
8597 } elseif {$searchdirn eq "-forwards"} {
8598 $ctext mark set anchor @0,0
8599 } else {
8600 $ctext mark set anchor @0,[winfo height $ctext]
8601 }
8602 }
8603 if {$searchstring ne {}} {
8604 set here [$ctext search -count mlen $searchdirn -- $searchstring anchor]
8605 if {$here ne {}} {
8606 $ctext see $here
8607 set mend "$here + $mlen c"
8608 $ctext tag remove sel 1.0 end
8609 $ctext tag add sel $here $mend
8610 suppress_highlighting_file_for_current_scrollpos
8611 highlightfile_for_scrollpos $here
8612 }
8613 }
8614 rehighlight_search_results
8615}
8616
8617proc dosearch {} {
8618 global sstring ctext searchstring searchdirn
8619
8620 focus $sstring
8621 $sstring icursor end
8622 set searchdirn -forwards
8623 if {$searchstring ne {}} {
8624 set sel [$ctext tag ranges sel]
8625 if {$sel ne {}} {
8626 set start "[lindex $sel 0] + 1c"
8627 } elseif {[catch {set start [$ctext index anchor]}]} {
8628 set start "@0,0"
8629 }
8630 set match [$ctext search -count mlen -- $searchstring $start]
8631 $ctext tag remove sel 1.0 end
8632 if {$match eq {}} {
8633 bell
8634 return
8635 }
8636 $ctext see $match
8637 suppress_highlighting_file_for_current_scrollpos
8638 highlightfile_for_scrollpos $match
8639 set mend "$match + $mlen c"
8640 $ctext tag add sel $match $mend
8641 $ctext mark unset anchor
8642 rehighlight_search_results
8643 }
8644}
8645
8646proc dosearchback {} {
8647 global sstring ctext searchstring searchdirn
8648
8649 focus $sstring
8650 $sstring icursor end
8651 set searchdirn -backwards
8652 if {$searchstring ne {}} {
8653 set sel [$ctext tag ranges sel]
8654 if {$sel ne {}} {
8655 set start [lindex $sel 0]
8656 } elseif {[catch {set start [$ctext index anchor]}]} {
8657 set start @0,[winfo height $ctext]
8658 }
8659 set match [$ctext search -backwards -count ml -- $searchstring $start]
8660 $ctext tag remove sel 1.0 end
8661 if {$match eq {}} {
8662 bell
8663 return
8664 }
8665 $ctext see $match
8666 suppress_highlighting_file_for_current_scrollpos
8667 highlightfile_for_scrollpos $match
8668 set mend "$match + $ml c"
8669 $ctext tag add sel $match $mend
8670 $ctext mark unset anchor
8671 rehighlight_search_results
8672 }
8673}
8674
8675proc rehighlight_search_results {} {
8676 global ctext searchstring
8677
8678 $ctext tag remove found 1.0 end
8679 $ctext tag remove currentsearchhit 1.0 end
8680
8681 if {$searchstring ne {}} {
8682 searchmarkvisible 1
8683 }
8684}
8685
8686proc searchmark {first last} {
8687 global ctext searchstring
8688
8689 set sel [$ctext tag ranges sel]
8690
8691 set mend $first.0
8692 while {1} {
8693 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
8694 if {$match eq {}} break
8695 set mend "$match + $mlen c"
8696 if {$sel ne {} && [$ctext compare $match == [lindex $sel 0]]} {
8697 $ctext tag add currentsearchhit $match $mend
8698 } else {
8699 $ctext tag add found $match $mend
8700 }
8701 }
8702}
8703
8704proc searchmarkvisible {doall} {
8705 global ctext smarktop smarkbot
8706
8707 set topline [lindex [split [$ctext index @0,0] .] 0]
8708 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
8709 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
8710 # no overlap with previous
8711 searchmark $topline $botline
8712 set smarktop $topline
8713 set smarkbot $botline
8714 } else {
8715 if {$topline < $smarktop} {
8716 searchmark $topline [expr {$smarktop-1}]
8717 set smarktop $topline
8718 }
8719 if {$botline > $smarkbot} {
8720 searchmark [expr {$smarkbot+1}] $botline
8721 set smarkbot $botline
8722 }
8723 }
8724}
8725
8726proc suppress_highlighting_file_for_current_scrollpos {} {
8727 global ctext suppress_highlighting_file_for_this_scrollpos
8728
8729 set suppress_highlighting_file_for_this_scrollpos [$ctext index @0,0]
8730}
8731
8732proc scrolltext {f0 f1} {
8733 global searchstring cmitmode ctext
8734 global suppress_highlighting_file_for_this_scrollpos
8735
8736 set topidx [$ctext index @0,0]
8737 if {![info exists suppress_highlighting_file_for_this_scrollpos]
8738 || $topidx ne $suppress_highlighting_file_for_this_scrollpos} {
8739 highlightfile_for_scrollpos $topidx
8740 }
8741
8742 unset -nocomplain suppress_highlighting_file_for_this_scrollpos
8743
8744 .bleft.bottom.sb set $f0 $f1
8745 if {$searchstring ne {}} {
8746 searchmarkvisible 0
8747 }
8748}
8749
8750proc setcoords {} {
8751 global linespc charspc canvx0 canvy0
8752 global xspc1 xspc2 lthickness
8753
8754 set linespc [font metrics mainfont -linespace]
8755 set charspc [font measure mainfont "m"]
8756 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
8757 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
8758 set lthickness [expr {int($linespc / 9) + 1}]
8759 set xspc1(0) $linespc
8760 set xspc2 $linespc
8761}
8762
8763proc redisplay {} {
8764 global canv
8765 global selectedline
8766
8767 set ymax [lindex [$canv cget -scrollregion] 3]
8768 if {$ymax eq {} || $ymax == 0} return
8769 set span [$canv yview]
8770 clear_display
8771 setcanvscroll
8772 allcanvs yview moveto [lindex $span 0]
8773 drawvisible
8774 if {$selectedline ne {}} {
8775 selectline $selectedline 0
8776 allcanvs yview moveto [lindex $span 0]
8777 }
8778}
8779
8780proc parsefont {f n} {
8781 global fontattr
8782
8783 set fontattr($f,family) [lindex $n 0]
8784 set s [lindex $n 1]
8785 if {$s eq {} || $s == 0} {
8786 set s 10
8787 } elseif {$s < 0} {
8788 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
8789 }
8790 set fontattr($f,size) $s
8791 set fontattr($f,weight) normal
8792 set fontattr($f,slant) roman
8793 foreach style [lrange $n 2 end] {
8794 switch -- $style {
8795 "normal" -
8796 "bold" {set fontattr($f,weight) $style}
8797 "roman" -
8798 "italic" {set fontattr($f,slant) $style}
8799 }
8800 }
8801}
8802
8803proc fontflags {f {isbold 0}} {
8804 global fontattr
8805
8806 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
8807 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
8808 -slant $fontattr($f,slant)]
8809}
8810
8811proc fontname {f} {
8812 global fontattr
8813
8814 set n [list $fontattr($f,family) $fontattr($f,size)]
8815 if {$fontattr($f,weight) eq "bold"} {
8816 lappend n "bold"
8817 }
8818 if {$fontattr($f,slant) eq "italic"} {
8819 lappend n "italic"
8820 }
8821 return $n
8822}
8823
8824proc incrfont {inc} {
8825 global mainfont textfont ctext canv cflist showrefstop
8826 global stopped entries fontattr
8827
8828 unmarkmatches
8829 set s $fontattr(mainfont,size)
8830 incr s $inc
8831 if {$s < 1} {
8832 set s 1
8833 }
8834 set fontattr(mainfont,size) $s
8835 font config mainfont -size $s
8836 font config mainfontbold -size $s
8837 set mainfont [fontname mainfont]
8838 set s $fontattr(textfont,size)
8839 incr s $inc
8840 if {$s < 1} {
8841 set s 1
8842 }
8843 set fontattr(textfont,size) $s
8844 font config textfont -size $s
8845 font config textfontbold -size $s
8846 set textfont [fontname textfont]
8847 setcoords
8848 settabs
8849 redisplay
8850}
8851
8852proc clearsha1 {} {
8853 global sha1entry sha1string
8854 global hashlength
8855
8856 if {[string length $sha1string] == $hashlength} {
8857 $sha1entry delete 0 end
8858 }
8859}
8860
8861proc sha1change {n1 n2 op} {
8862 global sha1string currentid sha1but
8863
8864 if {$sha1string == {}
8865 || ([info exists currentid] && $sha1string == $currentid)} {
8866 set state disabled
8867 } else {
8868 set state normal
8869 }
8870 if {[$sha1but cget -state] == $state} return
8871 if {$state == "normal"} {
8872 $sha1but conf -state normal -text "[mc "Goto:"] "
8873 } else {
8874 $sha1but conf -state disabled -text "[mc "Commit ID:"] "
8875 }
8876}
8877
8878proc gotocommit {} {
8879 global sha1string tagids headids curview varcid
8880 global hashlength
8881
8882 if {$sha1string == {}
8883 || ([info exists currentid] && $sha1string == $currentid)} return
8884 if {[info exists tagids($sha1string)]} {
8885 set id $tagids($sha1string)
8886 } elseif {[info exists headids($sha1string)]} {
8887 set id $headids($sha1string)
8888 } else {
8889 set id [string tolower $sha1string]
8890 if {[regexp {^[0-9a-f]{4,63}$} $id]} {
8891 set matches [longid $id]
8892 if {$matches ne {}} {
8893 if {[llength $matches] > 1} {
8894 error_popup [mc "Short commit ID %s is ambiguous" $id]
8895 return
8896 }
8897 set id [lindex $matches 0]
8898 }
8899 } else {
8900 if {[catch {set id [safe_exec [list git rev-parse --verify $sha1string]]}]} {
8901 error_popup [mc "Revision %s is not known" $sha1string]
8902 return
8903 }
8904 }
8905 }
8906 if {[commitinview $id $curview]} {
8907 selectline [rowofcommit $id] 1
8908 return
8909 }
8910 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
8911 set msg [mc "Commit ID %s is not known" $sha1string]
8912 } else {
8913 set msg [mc "Revision %s is not in the current view" $sha1string]
8914 }
8915 error_popup $msg
8916}
8917
8918proc lineenter {x y id} {
8919 global hoverx hovery hoverid hovertimer
8920 global commitinfo canv
8921
8922 if {![info exists commitinfo($id)] && ![getcommit $id]} return
8923 set hoverx $x
8924 set hovery $y
8925 set hoverid $id
8926 if {[info exists hovertimer]} {
8927 after cancel $hovertimer
8928 }
8929 set hovertimer [after 500 linehover]
8930 $canv delete hover
8931}
8932
8933proc linemotion {x y id} {
8934 global hoverx hovery hoverid hovertimer
8935
8936 if {[info exists hoverid] && $id == $hoverid} {
8937 set hoverx $x
8938 set hovery $y
8939 if {[info exists hovertimer]} {
8940 after cancel $hovertimer
8941 }
8942 set hovertimer [after 500 linehover]
8943 }
8944}
8945
8946proc lineleave {id} {
8947 global hoverid hovertimer canv
8948
8949 if {[info exists hoverid] && $id == $hoverid} {
8950 $canv delete hover
8951 if {[info exists hovertimer]} {
8952 after cancel $hovertimer
8953 unset hovertimer
8954 }
8955 unset hoverid
8956 }
8957}
8958
8959proc linehover {} {
8960 global hoverx hovery hoverid hovertimer
8961 global canv linespc lthickness
8962 global linehoverbgcolor linehoverfgcolor linehoveroutlinecolor
8963
8964 global commitinfo
8965
8966 set text [lindex $commitinfo($hoverid) 0]
8967 set ymax [lindex [$canv cget -scrollregion] 3]
8968 if {$ymax == {}} return
8969 set yfrac [lindex [$canv yview] 0]
8970 set x [expr {$hoverx + 2 * $linespc}]
8971 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
8972 set x0 [expr {$x - 2 * $lthickness}]
8973 set y0 [expr {$y - 2 * $lthickness}]
8974 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
8975 set y1 [expr {$y + $linespc + 2 * $lthickness}]
8976 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
8977 -fill $linehoverbgcolor -outline $linehoveroutlinecolor \
8978 -width 1 -tags hover]
8979 $canv raise $t
8980 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
8981 -font mainfont -fill $linehoverfgcolor]
8982 $canv raise $t
8983}
8984
8985proc clickisonarrow {id y} {
8986 global lthickness
8987
8988 set ranges [rowranges $id]
8989 set thresh [expr {2 * $lthickness + 6}]
8990 set n [expr {[llength $ranges] - 1}]
8991 for {set i 1} {$i < $n} {incr i} {
8992 set row [lindex $ranges $i]
8993 if {abs([yc $row] - $y) < $thresh} {
8994 return $i
8995 }
8996 }
8997 return {}
8998}
8999
9000proc arrowjump {id n y} {
9001 global canv
9002
9003 # 1 <-> 2, 3 <-> 4, etc...
9004 set n [expr {(($n - 1) ^ 1) + 1}]
9005 set row [lindex [rowranges $id] $n]
9006 set yt [yc $row]
9007 set ymax [lindex [$canv cget -scrollregion] 3]
9008 if {$ymax eq {} || $ymax <= 0} return
9009 set view [$canv yview]
9010 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
9011 set yfrac [expr {$yt / $ymax - $yspan / 2}]
9012 if {$yfrac < 0} {
9013 set yfrac 0
9014 }
9015 allcanvs yview moveto $yfrac
9016}
9017
9018proc lineclick {x y id isnew} {
9019 global ctext commitinfo children canv thickerline curview
9020
9021 if {![info exists commitinfo($id)] && ![getcommit $id]} return
9022 unmarkmatches
9023 unselectline
9024 normalline
9025 $canv delete hover
9026 # draw this line thicker than normal
9027 set thickerline $id
9028 drawlines $id
9029 if {$isnew} {
9030 set ymax [lindex [$canv cget -scrollregion] 3]
9031 if {$ymax eq {}} return
9032 set yfrac [lindex [$canv yview] 0]
9033 set y [expr {$y + $yfrac * $ymax}]
9034 }
9035 set dirn [clickisonarrow $id $y]
9036 if {$dirn ne {}} {
9037 arrowjump $id $dirn $y
9038 return
9039 }
9040
9041 if {$isnew} {
9042 addtohistory [list lineclick $x $y $id 0] savectextpos
9043 }
9044 # fill the details pane with info about this line
9045 $ctext conf -state normal
9046 clear_ctext
9047 settabs 0
9048 $ctext insert end "[mc "Parent"]:\t"
9049 $ctext insert end $id link0
9050 setlink $id link0
9051 set info $commitinfo($id)
9052 $ctext insert end "\n\t[lindex $info 0]\n"
9053 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
9054 set date [formatdate [lindex $info 2]]
9055 $ctext insert end "\t[mc "Date"]:\t$date\n"
9056 set kids $children($curview,$id)
9057 if {$kids ne {}} {
9058 $ctext insert end "\n[mc "Children"]:"
9059 set i 0
9060 foreach child $kids {
9061 incr i
9062 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
9063 set info $commitinfo($child)
9064 $ctext insert end "\n\t"
9065 $ctext insert end $child link$i
9066 setlink $child link$i
9067 $ctext insert end "\n\t[lindex $info 0]"
9068 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
9069 set date [formatdate [lindex $info 2]]
9070 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
9071 }
9072 }
9073 maybe_scroll_ctext 1
9074 $ctext conf -state disabled
9075 init_flist {}
9076}
9077
9078proc normalline {} {
9079 global thickerline
9080 if {[info exists thickerline]} {
9081 set id $thickerline
9082 unset thickerline
9083 drawlines $id
9084 }
9085}
9086
9087proc selbyid {id {isnew 1}} {
9088 global curview
9089 if {[commitinview $id $curview]} {
9090 selectline [rowofcommit $id] $isnew
9091 }
9092}
9093
9094proc mstime {} {
9095 global startmstime
9096 if {![info exists startmstime]} {
9097 set startmstime [clock clicks -milliseconds]
9098 }
9099 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
9100}
9101
9102proc rowmenu {x y id} {
9103 global rowctxmenu selectedline rowmenuid curview
9104 global nullid nullid2 fakerowmenu mainhead markedid
9105
9106 stopfinding
9107 set rowmenuid $id
9108 if {$selectedline eq {} || [rowofcommit $id] eq $selectedline} {
9109 set state disabled
9110 } else {
9111 set state normal
9112 }
9113 if {[info exists markedid] && $markedid ne $id} {
9114 set mstate normal
9115 } else {
9116 set mstate disabled
9117 }
9118 if {$id ne $nullid && $id ne $nullid2} {
9119 set menu $rowctxmenu
9120 if {$mainhead ne {}} {
9121 $menu entryconfigure 8 -label [mc "Reset %s branch to here" $mainhead] -state normal
9122 } else {
9123 $menu entryconfigure 8 -label [mc "Detached head: can't reset" $mainhead] -state disabled
9124 }
9125 $menu entryconfigure 10 -state $mstate
9126 $menu entryconfigure 11 -state $mstate
9127 $menu entryconfigure 12 -state $mstate
9128 } else {
9129 set menu $fakerowmenu
9130 }
9131 $menu entryconfigure [mca "Diff this -> selected"] -state $state
9132 $menu entryconfigure [mca "Diff selected -> this"] -state $state
9133 $menu entryconfigure [mca "Make patch"] -state $state
9134 $menu entryconfigure [mca "Diff this -> marked commit"] -state $mstate
9135 $menu entryconfigure [mca "Diff marked commit -> this"] -state $mstate
9136 tk_popup $menu $x $y
9137}
9138
9139proc markhere {} {
9140 global rowmenuid markedid canv
9141
9142 set markedid $rowmenuid
9143 make_idmark $markedid
9144}
9145
9146proc gotomark {} {
9147 global markedid
9148
9149 if {[info exists markedid]} {
9150 selbyid $markedid
9151 }
9152}
9153
9154proc replace_by_kids {l r} {
9155 global curview children
9156
9157 set id [commitonrow $r]
9158 set l [lreplace $l 0 0]
9159 foreach kid $children($curview,$id) {
9160 lappend l [rowofcommit $kid]
9161 }
9162 return [lsort -integer -decreasing -unique $l]
9163}
9164
9165proc find_common_desc {} {
9166 global markedid rowmenuid curview children
9167
9168 if {![info exists markedid]} return
9169 if {![commitinview $markedid $curview] ||
9170 ![commitinview $rowmenuid $curview]} return
9171 #set t1 [clock clicks -milliseconds]
9172 set l1 [list [rowofcommit $markedid]]
9173 set l2 [list [rowofcommit $rowmenuid]]
9174 while 1 {
9175 set r1 [lindex $l1 0]
9176 set r2 [lindex $l2 0]
9177 if {$r1 eq {} || $r2 eq {}} break
9178 if {$r1 == $r2} {
9179 selectline $r1 1
9180 break
9181 }
9182 if {$r1 > $r2} {
9183 set l1 [replace_by_kids $l1 $r1]
9184 } else {
9185 set l2 [replace_by_kids $l2 $r2]
9186 }
9187 }
9188 #set t2 [clock clicks -milliseconds]
9189 #puts "took [expr {$t2-$t1}]ms"
9190}
9191
9192proc compare_commits {} {
9193 global markedid rowmenuid curview children
9194
9195 if {![info exists markedid]} return
9196 if {![commitinview $markedid $curview]} return
9197 addtohistory [list do_cmp_commits $markedid $rowmenuid]
9198 do_cmp_commits $markedid $rowmenuid
9199}
9200
9201proc getpatchid {id} {
9202 global patchids
9203
9204 if {![info exists patchids($id)]} {
9205 set cmd [diffcmd [list $id] {-p --root}]
9206 if {[catch {
9207 set x [safe_exec_redirect $cmd [list | git patch-id]]
9208 set patchids($id) [lindex $x 0]
9209 }]} {
9210 set patchids($id) "error"
9211 }
9212 }
9213 return $patchids($id)
9214}
9215
9216proc do_cmp_commits {a b} {
9217 global ctext curview parents children patchids commitinfo
9218
9219 $ctext conf -state normal
9220 clear_ctext
9221 init_flist {}
9222 for {set i 0} {$i < 100} {incr i} {
9223 set skipa 0
9224 set skipb 0
9225 if {[llength $parents($curview,$a)] > 1} {
9226 appendshortlink $a [mc "Skipping merge commit "] "\n"
9227 set skipa 1
9228 } else {
9229 set patcha [getpatchid $a]
9230 }
9231 if {[llength $parents($curview,$b)] > 1} {
9232 appendshortlink $b [mc "Skipping merge commit "] "\n"
9233 set skipb 1
9234 } else {
9235 set patchb [getpatchid $b]
9236 }
9237 if {!$skipa && !$skipb} {
9238 set heada [lindex $commitinfo($a) 0]
9239 set headb [lindex $commitinfo($b) 0]
9240 if {$patcha eq "error"} {
9241 appendshortlink $a [mc "Error getting patch ID for "] \
9242 [mc " - stopping\n"]
9243 break
9244 }
9245 if {$patchb eq "error"} {
9246 appendshortlink $b [mc "Error getting patch ID for "] \
9247 [mc " - stopping\n"]
9248 break
9249 }
9250 if {$patcha eq $patchb} {
9251 if {$heada eq $headb} {
9252 appendshortlink $a [mc "Commit "]
9253 appendshortlink $b " == " " $heada\n"
9254 } else {
9255 appendshortlink $a [mc "Commit "] " $heada\n"
9256 appendshortlink $b [mc " is the same patch as\n "] \
9257 " $headb\n"
9258 }
9259 set skipa 1
9260 set skipb 1
9261 } else {
9262 $ctext insert end "\n"
9263 appendshortlink $a [mc "Commit "] " $heada\n"
9264 appendshortlink $b [mc " differs from\n "] \
9265 " $headb\n"
9266 $ctext insert end [mc "Diff of commits:\n\n"]
9267 $ctext conf -state disabled
9268 update
9269 diffcommits $a $b
9270 return
9271 }
9272 }
9273 if {$skipa} {
9274 set kids [real_children $curview,$a]
9275 if {[llength $kids] != 1} {
9276 $ctext insert end "\n"
9277 appendshortlink $a [mc "Commit "] \
9278 [mc " has %s children - stopping\n" [llength $kids]]
9279 break
9280 }
9281 set a [lindex $kids 0]
9282 }
9283 if {$skipb} {
9284 set kids [real_children $curview,$b]
9285 if {[llength $kids] != 1} {
9286 appendshortlink $b [mc "Commit "] \
9287 [mc " has %s children - stopping\n" [llength $kids]]
9288 break
9289 }
9290 set b [lindex $kids 0]
9291 }
9292 }
9293 $ctext conf -state disabled
9294}
9295
9296proc diffcommits {a b} {
9297 global diffcontext diffids blobdifffd diffinhdr currdiffsubmod
9298
9299 set tmpdir [gitknewtmpdir]
9300 set fna [file join $tmpdir "commit-[string range $a 0 7]"]
9301 set fnb [file join $tmpdir "commit-[string range $b 0 7]"]
9302 if {[catch {
9303 safe_exec_redirect [list git diff-tree -p --pretty $a] [list >$fna]
9304 safe_exec_redirect [list git diff-tree -p --pretty $b] [list >$fnb]
9305 } err]} {
9306 error_popup [mc "Error writing commit to file: %s" $err]
9307 return
9308 }
9309 if {[catch {
9310 set fd [safe_open_command "diff -U$diffcontext $fna $fnb"]
9311 } err]} {
9312 error_popup [mc "Error diffing commits: %s" $err]
9313 return
9314 }
9315 set diffids [list commits $a $b]
9316 set blobdifffd($diffids) $fd
9317 set diffinhdr 0
9318 set currdiffsubmod ""
9319 filerun $fd [list getblobdiffline $fd $diffids]
9320}
9321
9322proc diffvssel {dirn} {
9323 global rowmenuid selectedline
9324
9325 if {$selectedline eq {}} return
9326 if {$dirn} {
9327 set oldid [commitonrow $selectedline]
9328 set newid $rowmenuid
9329 } else {
9330 set oldid $rowmenuid
9331 set newid [commitonrow $selectedline]
9332 }
9333 addtohistory [list doseldiff $oldid $newid] savectextpos
9334 doseldiff $oldid $newid
9335}
9336
9337proc diffvsmark {dirn} {
9338 global rowmenuid markedid
9339
9340 if {![info exists markedid]} return
9341 if {$dirn} {
9342 set oldid $markedid
9343 set newid $rowmenuid
9344 } else {
9345 set oldid $rowmenuid
9346 set newid $markedid
9347 }
9348 addtohistory [list doseldiff $oldid $newid] savectextpos
9349 doseldiff $oldid $newid
9350}
9351
9352proc doseldiff {oldid newid} {
9353 global ctext
9354 global commitinfo
9355
9356 $ctext conf -state normal
9357 clear_ctext
9358 init_flist [mc "Top"]
9359 $ctext insert end "[mc "From"] "
9360 $ctext insert end $oldid link0
9361 setlink $oldid link0
9362 $ctext insert end "\n "
9363 $ctext insert end [lindex $commitinfo($oldid) 0]
9364 $ctext insert end "\n\n[mc "To"] "
9365 $ctext insert end $newid link1
9366 setlink $newid link1
9367 $ctext insert end "\n "
9368 $ctext insert end [lindex $commitinfo($newid) 0]
9369 $ctext insert end "\n"
9370 $ctext conf -state disabled
9371 $ctext tag remove found 1.0 end
9372 startdiff [list $oldid $newid]
9373}
9374
9375proc mkpatch {} {
9376 global rowmenuid currentid commitinfo patchtop patchnum
9377 global hashlength
9378
9379 if {![info exists currentid]} return
9380 set oldid $currentid
9381 set oldhead [lindex $commitinfo($oldid) 0]
9382 set newid $rowmenuid
9383 set newhead [lindex $commitinfo($newid) 0]
9384 set top .patch
9385 set patchtop $top
9386 catch {destroy $top}
9387 ttk_toplevel $top
9388 make_transient $top .
9389 ttk::label $top.title -text [mc "Generate patch"]
9390 grid $top.title - -pady 10
9391 ttk::label $top.from -text [mc "From:"]
9392 ttk::entry $top.fromsha1 -width $hashlength
9393 $top.fromsha1 insert 0 $oldid
9394 $top.fromsha1 conf -state readonly
9395 grid $top.from $top.fromsha1 -sticky w
9396 ttk::entry $top.fromhead -width 60
9397 $top.fromhead insert 0 $oldhead
9398 $top.fromhead conf -state readonly
9399 grid x $top.fromhead -sticky w
9400 ttk::label $top.to -text [mc "To:"]
9401 ttk::entry $top.tosha1 -width $hashlength
9402 $top.tosha1 insert 0 $newid
9403 $top.tosha1 conf -state readonly
9404 grid $top.to $top.tosha1 -sticky w
9405 ttk::entry $top.tohead -width 60
9406 $top.tohead insert 0 $newhead
9407 $top.tohead conf -state readonly
9408 grid x $top.tohead -sticky w
9409 ttk::button $top.rev -text [mc "Reverse"] -command mkpatchrev
9410 grid $top.rev x -pady 10 -padx 5
9411 ttk::label $top.flab -text [mc "Output file:"]
9412 ttk::entry $top.fname -width 60
9413 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
9414 incr patchnum
9415 grid $top.flab $top.fname -sticky w
9416 ttk::frame $top.buts
9417 ttk::button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
9418 ttk::button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
9419 bind $top <Key-Return> mkpatchgo
9420 bind $top <Key-Escape> mkpatchcan
9421 grid $top.buts.gen $top.buts.can
9422 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9423 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9424 grid $top.buts - -pady 10 -sticky ew
9425 focus $top.fname
9426}
9427
9428proc mkpatchrev {} {
9429 global patchtop
9430
9431 set oldid [$patchtop.fromsha1 get]
9432 set oldhead [$patchtop.fromhead get]
9433 set newid [$patchtop.tosha1 get]
9434 set newhead [$patchtop.tohead get]
9435 foreach e [list fromsha1 fromhead tosha1 tohead] \
9436 v [list $newid $newhead $oldid $oldhead] {
9437 $patchtop.$e conf -state normal
9438 $patchtop.$e delete 0 end
9439 $patchtop.$e insert 0 $v
9440 $patchtop.$e conf -state readonly
9441 }
9442}
9443
9444proc mkpatchgo {} {
9445 global patchtop nullid nullid2
9446
9447 set oldid [$patchtop.fromsha1 get]
9448 set newid [$patchtop.tosha1 get]
9449 set fname [$patchtop.fname get]
9450 set cmd [diffcmd [list $oldid $newid] -p]
9451 if {[catch {safe_exec_redirect $cmd [list >$fname &]} err]} {
9452 error_popup "[mc "Error creating patch:"] $err" $patchtop
9453 }
9454 catch {destroy $patchtop}
9455 unset patchtop
9456}
9457
9458proc mkpatchcan {} {
9459 global patchtop
9460
9461 catch {destroy $patchtop}
9462 unset patchtop
9463}
9464
9465proc mktag {} {
9466 global rowmenuid mktagtop commitinfo
9467 global hashlength
9468
9469 set top .maketag
9470 set mktagtop $top
9471 catch {destroy $top}
9472 ttk_toplevel $top
9473 make_transient $top .
9474 ttk::label $top.title -text [mc "Create tag"]
9475 grid $top.title - -pady 10
9476 ttk::label $top.id -text [mc "ID:"]
9477 ttk::entry $top.sha1 -width $hashlength
9478 $top.sha1 insert 0 $rowmenuid
9479 $top.sha1 conf -state readonly
9480 grid $top.id $top.sha1 -sticky w
9481 ttk::entry $top.head -width 60
9482 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9483 $top.head conf -state readonly
9484 grid x $top.head -sticky w
9485 ttk::label $top.tlab -text [mc "Tag name:"]
9486 ttk::entry $top.tag -width 60
9487 grid $top.tlab $top.tag -sticky w
9488 ttk::label $top.op -text [mc "Tag message is optional"]
9489 grid $top.op -columnspan 2 -sticky we
9490 ttk::label $top.mlab -text [mc "Tag message:"]
9491 ttk::entry $top.msg -width 60
9492 grid $top.mlab $top.msg -sticky w
9493 ttk::frame $top.buts
9494 ttk::button $top.buts.gen -text [mc "Create"] -command mktaggo
9495 ttk::button $top.buts.can -text [mc "Cancel"] -command mktagcan
9496 bind $top <Key-Return> mktaggo
9497 bind $top <Key-Escape> mktagcan
9498 grid $top.buts.gen $top.buts.can
9499 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9500 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9501 grid $top.buts - -pady 10 -sticky ew
9502 focus $top.tag
9503}
9504
9505proc domktag {} {
9506 global mktagtop env tagids idtags
9507
9508 set id [$mktagtop.sha1 get]
9509 set tag [$mktagtop.tag get]
9510 set msg [$mktagtop.msg get]
9511 if {$tag == {}} {
9512 error_popup [mc "No tag name specified"] $mktagtop
9513 return 0
9514 }
9515 if {[info exists tagids($tag)]} {
9516 error_popup [mc "Tag \"%s\" already exists" $tag] $mktagtop
9517 return 0
9518 }
9519 if {[catch {
9520 if {$msg != {}} {
9521 safe_exec [list git tag -a -m $msg $tag $id]
9522 } else {
9523 safe_exec [list git tag $tag $id]
9524 }
9525 } err]} {
9526 error_popup "[mc "Error creating tag:"] $err" $mktagtop
9527 return 0
9528 }
9529
9530 set tagids($tag) $id
9531 lappend idtags($id) $tag
9532 redrawtags $id
9533 addedtag $id
9534 dispneartags 0
9535 run refill_reflist
9536 return 1
9537}
9538
9539proc redrawtags {id} {
9540 global canv linehtag idpos currentid curview cmitlisted markedid
9541 global canvxmax iddrawn circleitem mainheadid circlecolors
9542 global mainheadcirclecolor
9543
9544 if {![commitinview $id $curview]} return
9545 if {![info exists iddrawn($id)]} return
9546 set row [rowofcommit $id]
9547 if {$id eq $mainheadid} {
9548 set ofill $mainheadcirclecolor
9549 } else {
9550 set ofill [lindex $circlecolors $cmitlisted($curview,$id)]
9551 }
9552 $canv itemconf $circleitem($row) -fill $ofill
9553 $canv delete tag.$id
9554 set xt [eval drawtags $id $idpos($id)]
9555 $canv coords $linehtag($id) $xt [lindex $idpos($id) 2]
9556 set text [$canv itemcget $linehtag($id) -text]
9557 set font [$canv itemcget $linehtag($id) -font]
9558 set xr [expr {$xt + [font measure $font $text]}]
9559 if {$xr > $canvxmax} {
9560 set canvxmax $xr
9561 setcanvscroll
9562 }
9563 if {[info exists currentid] && $currentid == $id} {
9564 make_secsel $id
9565 }
9566 if {[info exists markedid] && $markedid eq $id} {
9567 make_idmark $id
9568 }
9569}
9570
9571proc mktagcan {} {
9572 global mktagtop
9573
9574 catch {destroy $mktagtop}
9575 unset mktagtop
9576}
9577
9578proc mktaggo {} {
9579 if {![domktag]} return
9580 mktagcan
9581}
9582
9583proc copyreference {} {
9584 global rowmenuid autosellen
9585 global hashlength
9586
9587 set format "%h (\"%s\", %ad)"
9588 set cmd [list git show -s --pretty=format:$format --date=short]
9589 if {$autosellen < $hashlength} {
9590 lappend cmd --abbrev=$autosellen
9591 }
9592 set reference [safe_exec [concat $cmd $rowmenuid]]
9593
9594 clipboard clear
9595 clipboard append $reference
9596}
9597
9598proc writecommit {} {
9599 global rowmenuid wrcomtop commitinfo wrcomcmd
9600 global hashlength
9601
9602 set top .writecommit
9603 set wrcomtop $top
9604 catch {destroy $top}
9605 ttk_toplevel $top
9606 make_transient $top .
9607 ttk::label $top.title -text [mc "Write commit to file"]
9608 grid $top.title - -pady 10
9609 ttk::label $top.id -text [mc "ID:"]
9610 ttk::entry $top.sha1 -width $hashlength
9611 $top.sha1 insert 0 $rowmenuid
9612 $top.sha1 conf -state readonly
9613 grid $top.id $top.sha1 -sticky w
9614 ttk::entry $top.head -width 60
9615 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
9616 $top.head conf -state readonly
9617 grid x $top.head -sticky w
9618 ttk::label $top.clab -text [mc "Command:"]
9619 ttk::entry $top.cmd -width 60 -textvariable wrcomcmd
9620 grid $top.clab $top.cmd -sticky w -pady 10
9621 ttk::label $top.flab -text [mc "Output file:"]
9622 ttk::entry $top.fname -width 60
9623 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
9624 grid $top.flab $top.fname -sticky w
9625 ttk::frame $top.buts
9626 ttk::button $top.buts.gen -text [mc "Write"] -command wrcomgo
9627 ttk::button $top.buts.can -text [mc "Cancel"] -command wrcomcan
9628 bind $top <Key-Return> wrcomgo
9629 bind $top <Key-Escape> wrcomcan
9630 grid $top.buts.gen $top.buts.can
9631 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9632 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9633 grid $top.buts - -pady 10 -sticky ew
9634 focus $top.fname
9635}
9636
9637proc wrcomgo {} {
9638 global wrcomtop
9639
9640 set id [$wrcomtop.sha1 get]
9641 set cmd "echo $id | [$wrcomtop.cmd get]"
9642 set fname [$wrcomtop.fname get]
9643 if {[catch {safe_exec_redirect [list sh -c $cmd] [list >$fname &]} err]} {
9644 error_popup "[mc "Error writing commit:"] $err" $wrcomtop
9645 }
9646 catch {destroy $wrcomtop}
9647 unset wrcomtop
9648}
9649
9650proc wrcomcan {} {
9651 global wrcomtop
9652
9653 catch {destroy $wrcomtop}
9654 unset wrcomtop
9655}
9656
9657proc mkbranch {} {
9658 global rowmenuid
9659
9660 set top .branchdialog
9661
9662 set val(name) ""
9663 set val(id) $rowmenuid
9664 set val(command) [list mkbrgo $top]
9665
9666 set ui(title) [mc "Create branch"]
9667 set ui(accept) [mc "Create"]
9668
9669 branchdia $top val ui
9670}
9671
9672proc mvbranch {} {
9673 global headmenuid headmenuhead
9674
9675 set top .branchdialog
9676
9677 set val(name) $headmenuhead
9678 set val(id) $headmenuid
9679 set val(command) [list mvbrgo $top $headmenuhead]
9680
9681 set ui(title) [mc "Rename branch %s" $headmenuhead]
9682 set ui(accept) [mc "Rename"]
9683
9684 branchdia $top val ui
9685}
9686
9687proc branchdia {top valvar uivar} {
9688 global commitinfo
9689 global hashlength
9690 upvar $valvar val $uivar ui
9691
9692 catch {destroy $top}
9693 ttk_toplevel $top
9694 make_transient $top .
9695 ttk::label $top.title -text $ui(title)
9696 grid $top.title - -pady 10
9697 ttk::label $top.id -text [mc "ID:"]
9698 ttk::entry $top.sha1 -width $hashlength
9699 $top.sha1 insert 0 $val(id)
9700 $top.sha1 conf -state readonly
9701 grid $top.id $top.sha1 -sticky w
9702 ttk::entry $top.head -width 60
9703 $top.head insert 0 [lindex $commitinfo($val(id)) 0]
9704 $top.head conf -state readonly
9705 grid x $top.head -sticky ew
9706 grid columnconfigure $top 1 -weight 1
9707 ttk::label $top.nlab -text [mc "Name:"]
9708 ttk::entry $top.name -width $hashlength
9709 $top.name insert 0 $val(name)
9710 grid $top.nlab $top.name -sticky w
9711 ttk::frame $top.buts
9712 ttk::button $top.buts.go -text $ui(accept) -command $val(command)
9713 ttk::button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
9714 bind $top <Key-Return> $val(command)
9715 bind $top <Key-Escape> "catch {destroy $top}"
9716 grid $top.buts.go $top.buts.can
9717 grid columnconfigure $top.buts 0 -weight 1 -uniform a
9718 grid columnconfigure $top.buts 1 -weight 1 -uniform a
9719 grid $top.buts - -pady 10 -sticky ew
9720 focus $top.name
9721}
9722
9723proc mkbrgo {top} {
9724 global headids idheads
9725
9726 set name [$top.name get]
9727 set id [$top.sha1 get]
9728 set cmdargs {}
9729 set old_id {}
9730 if {$name eq {}} {
9731 error_popup [mc "Please specify a name for the new branch"] $top
9732 return
9733 }
9734 if {[info exists headids($name)]} {
9735 if {![confirm_popup [mc \
9736 "Branch '%s' already exists. Overwrite?" $name] $top]} {
9737 return
9738 }
9739 set old_id $headids($name)
9740 lappend cmdargs -f
9741 }
9742 catch {destroy $top}
9743 lappend cmdargs $name $id
9744 nowbusy newbranch
9745 update
9746 if {[catch {
9747 safe_exec [concat git branch $cmdargs]
9748 } err]} {
9749 notbusy newbranch
9750 error_popup $err
9751 } else {
9752 notbusy newbranch
9753 if {$old_id ne {}} {
9754 movehead $id $name
9755 movedhead $id $name
9756 redrawtags $old_id
9757 redrawtags $id
9758 } else {
9759 set headids($name) $id
9760 lappend idheads($id) $name
9761 addedhead $id $name
9762 redrawtags $id
9763 }
9764 dispneartags 0
9765 run refill_reflist
9766 }
9767}
9768
9769proc mvbrgo {top prevname} {
9770 global headids idheads mainhead mainheadid
9771
9772 set name [$top.name get]
9773 set id [$top.sha1 get]
9774 set cmdargs {}
9775 if {$name eq $prevname} {
9776 catch {destroy $top}
9777 return
9778 }
9779 if {$name eq {}} {
9780 error_popup [mc "Please specify a new name for the branch"] $top
9781 return
9782 }
9783 catch {destroy $top}
9784 lappend cmdargs -m $prevname $name
9785 nowbusy renamebranch
9786 update
9787 if {[catch {
9788 safe_exec [concat git branch $cmdargs]
9789 } err]} {
9790 notbusy renamebranch
9791 error_popup $err
9792 } else {
9793 notbusy renamebranch
9794 removehead $id $prevname
9795 removedhead $id $prevname
9796 set headids($name) $id
9797 lappend idheads($id) $name
9798 addedhead $id $name
9799 if {$prevname eq $mainhead} {
9800 set mainhead $name
9801 set mainheadid $id
9802 }
9803 redrawtags $id
9804 dispneartags 0
9805 run refill_reflist
9806 }
9807}
9808
9809proc exec_citool {tool_args {baseid {}}} {
9810 global commitinfo env
9811
9812 set save_env [array get env GIT_AUTHOR_*]
9813
9814 if {$baseid ne {}} {
9815 if {![info exists commitinfo($baseid)]} {
9816 getcommit $baseid
9817 }
9818 set author [lindex $commitinfo($baseid) 1]
9819 set date [lindex $commitinfo($baseid) 2]
9820 if {[regexp {^\s*(\S.*\S|\S)\s*<(.*)>\s*$} \
9821 $author author name email]
9822 && $date ne {}} {
9823 set env(GIT_AUTHOR_NAME) $name
9824 set env(GIT_AUTHOR_EMAIL) $email
9825 set env(GIT_AUTHOR_DATE) $date
9826 }
9827 }
9828
9829 safe_exec_redirect [concat git citool $tool_args] [list &]
9830
9831 array unset env GIT_AUTHOR_*
9832 array set env $save_env
9833}
9834
9835proc cherrypick {} {
9836 global rowmenuid curview
9837 global mainhead mainheadid
9838 global gitdir
9839
9840 set oldhead [exec git rev-parse HEAD]
9841 set dheads [descheads $rowmenuid]
9842 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
9843 set ok [confirm_popup [mc "Commit %s is already\
9844 included in branch %s -- really re-apply it?" \
9845 [string range $rowmenuid 0 7] $mainhead]]
9846 if {!$ok} return
9847 }
9848 nowbusy cherrypick [mc "Cherry-picking"]
9849 update
9850 # Unfortunately git-cherry-pick writes stuff to stderr even when
9851 # no error occurs, and exec takes that as an indication of error...
9852 if {[catch {safe_exec [list sh -c "git cherry-pick -r $rowmenuid 2>&1"]} err]} {
9853 notbusy cherrypick
9854 if {[regexp -line \
9855 {Entry '(.*)' (would be overwritten by merge|not uptodate)} \
9856 $err msg fname]} {
9857 error_popup [mc "Cherry-pick failed because of local changes\
9858 to file '%s'.\nPlease commit, reset or stash\
9859 your changes and try again." $fname]
9860 } elseif {[regexp -line \
9861 {^(CONFLICT \(.*\):|Automatic cherry-pick failed|error: could not apply)} \
9862 $err]} {
9863 if {[confirm_popup [mc "Cherry-pick failed because of merge\
9864 conflict.\nDo you wish to run git citool to\
9865 resolve it?"]]} {
9866 # Force citool to read MERGE_MSG
9867 file delete [file join $gitdir "GITGUI_MSG"]
9868 exec_citool {} $rowmenuid
9869 }
9870 } else {
9871 error_popup $err
9872 }
9873 run updatecommits
9874 return
9875 }
9876 set newhead [exec git rev-parse HEAD]
9877 if {$newhead eq $oldhead} {
9878 notbusy cherrypick
9879 error_popup [mc "No changes committed"]
9880 return
9881 }
9882 addnewchild $newhead $oldhead
9883 if {[commitinview $oldhead $curview]} {
9884 # XXX this isn't right if we have a path limit...
9885 insertrow $newhead $oldhead $curview
9886 if {$mainhead ne {}} {
9887 movehead $newhead $mainhead
9888 movedhead $newhead $mainhead
9889 }
9890 set mainheadid $newhead
9891 redrawtags $oldhead
9892 redrawtags $newhead
9893 selbyid $newhead
9894 }
9895 notbusy cherrypick
9896}
9897
9898proc revert {} {
9899 global rowmenuid curview
9900 global mainhead mainheadid
9901 global gitdir
9902
9903 set oldhead [exec git rev-parse HEAD]
9904 set dheads [descheads $rowmenuid]
9905 if { $dheads eq {} || [lsearch -exact $dheads $oldhead] == -1 } {
9906 set ok [confirm_popup [mc "Commit %s is not\
9907 included in branch %s -- really revert it?" \
9908 [string range $rowmenuid 0 7] $mainhead]]
9909 if {!$ok} return
9910 }
9911 nowbusy revert [mc "Reverting"]
9912 update
9913
9914 if [catch {safe_exec [list git revert --no-edit $rowmenuid]} err] {
9915 notbusy revert
9916 if [regexp {files would be overwritten by merge:(\n(( |\t)+[^\n]+\n)+)}\
9917 $err match files] {
9918 regsub {\n( |\t)+} $files "\n" files
9919 error_popup [mc "Revert failed because of local changes to\
9920 the following files:%s Please commit, reset or stash \
9921 your changes and try again." $files]
9922 } elseif [regexp {error: could not revert} $err] {
9923 if [confirm_popup [mc "Revert failed because of merge conflict.\n\
9924 Do you wish to run git citool to resolve it?"]] {
9925 # Force citool to read MERGE_MSG
9926 file delete [file join $gitdir "GITGUI_MSG"]
9927 exec_citool {} $rowmenuid
9928 }
9929 } else { error_popup $err }
9930 run updatecommits
9931 return
9932 }
9933
9934 set newhead [exec git rev-parse HEAD]
9935 if { $newhead eq $oldhead } {
9936 notbusy revert
9937 error_popup [mc "No changes committed"]
9938 return
9939 }
9940
9941 addnewchild $newhead $oldhead
9942
9943 if [commitinview $oldhead $curview] {
9944 # XXX this isn't right if we have a path limit...
9945 insertrow $newhead $oldhead $curview
9946 if {$mainhead ne {}} {
9947 movehead $newhead $mainhead
9948 movedhead $newhead $mainhead
9949 }
9950 set mainheadid $newhead
9951 redrawtags $oldhead
9952 redrawtags $newhead
9953 selbyid $newhead
9954 }
9955
9956 notbusy revert
9957}
9958
9959proc resethead {} {
9960 global mainhead rowmenuid confirm_ok resettype
9961
9962 set confirm_ok 0
9963 set w ".confirmreset"
9964 ttk_toplevel $w
9965 make_transient $w .
9966 wm title $w [mc "Confirm reset"]
9967 ttk::label $w.m -text \
9968 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]]
9969 pack $w.m -side top -fill x -padx 20 -pady 20
9970 ttk::labelframe $w.f -text [mc "Reset type:"]
9971 set resettype mixed
9972 ttk::radiobutton $w.f.soft -value soft -variable resettype \
9973 -text [mc "Soft: Leave working tree and index untouched"]
9974 grid $w.f.soft -sticky w
9975 ttk::radiobutton $w.f.mixed -value mixed -variable resettype \
9976 -text [mc "Mixed: Leave working tree untouched, reset index"]
9977 grid $w.f.mixed -sticky w
9978 ttk::radiobutton $w.f.hard -value hard -variable resettype \
9979 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
9980 grid $w.f.hard -sticky w
9981 pack $w.f -side top -fill x -padx 4
9982 ttk::button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
9983 pack $w.ok -side left -fill x -padx 20 -pady 20
9984 ttk::button $w.cancel -text [mc Cancel] -command "destroy $w"
9985 bind $w <Key-Escape> [list destroy $w]
9986 pack $w.cancel -side right -fill x -padx 20 -pady 20
9987 bind $w <Visibility> "grab $w; focus $w"
9988 tkwait window $w
9989 if {!$confirm_ok} return
9990 if {[catch {set fd [safe_open_command_redirect \
9991 [list git reset --$resettype $rowmenuid] [list 2>@1]]} err]} {
9992 error_popup $err
9993 } else {
9994 dohidelocalchanges
9995 filerun $fd [list readresetstat $fd]
9996 nowbusy reset [mc "Resetting"]
9997 selbyid $rowmenuid
9998 }
9999}
10000
10001proc readresetstat {fd} {
10002 global mainhead mainheadid showlocalchanges rprogcoord
10003
10004 if {[gets $fd line] >= 0} {
10005 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
10006 set rprogcoord [expr {1.0 * $m / $n}]
10007 adjustprogress
10008 }
10009 return 1
10010 }
10011 set rprogcoord 0
10012 adjustprogress
10013 notbusy reset
10014 if {[catch {close $fd} err]} {
10015 error_popup $err
10016 }
10017 set oldhead $mainheadid
10018 set newhead [exec git rev-parse HEAD]
10019 if {$newhead ne $oldhead} {
10020 movehead $newhead $mainhead
10021 movedhead $newhead $mainhead
10022 set mainheadid $newhead
10023 redrawtags $oldhead
10024 redrawtags $newhead
10025 }
10026 if {$showlocalchanges} {
10027 doshowlocalchanges
10028 }
10029 return 0
10030}
10031
10032# context menu for a head
10033proc headmenu {x y id head} {
10034 global headmenuid headmenuhead headctxmenu mainhead headids
10035
10036 stopfinding
10037 set headmenuid $id
10038 set headmenuhead $head
10039 array set state {0 normal 1 normal 2 normal}
10040 if {[string match "remotes/*" $head]} {
10041 set localhead [string range $head [expr [string last / $head] + 1] end]
10042 if {[info exists headids($localhead)]} {
10043 set state(0) disabled
10044 }
10045 array set state {1 disabled 2 disabled}
10046 }
10047 if {$head eq $mainhead} {
10048 array set state {0 disabled 2 disabled}
10049 }
10050 foreach i {0 1 2} {
10051 $headctxmenu entryconfigure $i -state $state($i)
10052 }
10053 tk_popup $headctxmenu $x $y
10054}
10055
10056proc cobranch {} {
10057 global headmenuid headmenuhead headids
10058 global showlocalchanges
10059
10060 # check the tree is clean first??
10061 set newhead $headmenuhead
10062 set command [list git checkout]
10063 if {[string match "remotes/*" $newhead]} {
10064 set remote $newhead
10065 set newhead [string range $newhead [expr [string last / $newhead] + 1] end]
10066 # The following check is redundant - the menu option should
10067 # be disabled to begin with...
10068 if {[info exists headids($newhead)]} {
10069 error_popup [mc "A local branch named %s exists already" $newhead]
10070 return
10071 }
10072 lappend command -b $newhead --track $remote
10073 } else {
10074 lappend command $newhead
10075 }
10076 nowbusy checkout [mc "Checking out"]
10077 update
10078 dohidelocalchanges
10079 if {[catch {
10080 set fd [safe_open_command_redirect $command [list 2>@1]]
10081 } err]} {
10082 notbusy checkout
10083 error_popup $err
10084 if {$showlocalchanges} {
10085 dodiffindex
10086 }
10087 } else {
10088 filerun $fd [list readcheckoutstat $fd $newhead $headmenuid]
10089 }
10090}
10091
10092proc readcheckoutstat {fd newhead newheadid} {
10093 global mainhead mainheadid headids idheads showlocalchanges progresscoords
10094 global viewmainheadid curview
10095
10096 if {[gets $fd line] >= 0} {
10097 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
10098 set progresscoords [list 0 [expr {1.0 * $m / $n}]]
10099 adjustprogress
10100 }
10101 return 1
10102 }
10103 set progresscoords {0 0}
10104 adjustprogress
10105 notbusy checkout
10106 if {[catch {close $fd} err]} {
10107 error_popup $err
10108 return
10109 }
10110 set oldmainid $mainheadid
10111 if {! [info exists headids($newhead)]} {
10112 set headids($newhead) $newheadid
10113 lappend idheads($newheadid) $newhead
10114 addedhead $newheadid $newhead
10115 }
10116 set mainhead $newhead
10117 set mainheadid $newheadid
10118 set viewmainheadid($curview) $newheadid
10119 redrawtags $oldmainid
10120 redrawtags $newheadid
10121 selbyid $newheadid
10122 if {$showlocalchanges} {
10123 dodiffindex
10124 }
10125}
10126
10127proc rmbranch {} {
10128 global headmenuid headmenuhead mainhead
10129 global idheads
10130
10131 set head $headmenuhead
10132 set id $headmenuid
10133 # this check shouldn't be needed any more...
10134 if {$head eq $mainhead} {
10135 error_popup [mc "Cannot delete the currently checked-out branch"]
10136 return
10137 }
10138 set dheads [descheads $id]
10139 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
10140 # the stuff on this branch isn't on any other branch
10141 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
10142 branch.\nReally delete branch %s?" $head $head]]} return
10143 }
10144 nowbusy rmbranch
10145 update
10146 if {[catch {safe_exec [list git branch -D $head]} err]} {
10147 notbusy rmbranch
10148 error_popup $err
10149 return
10150 }
10151 removehead $id $head
10152 removedhead $id $head
10153 redrawtags $id
10154 notbusy rmbranch
10155 dispneartags 0
10156 run refill_reflist
10157}
10158
10159# Display a list of tags and heads
10160proc showrefs {} {
10161 global showrefstop bgcolor fgcolor selectbgcolor
10162 global bglist fglist reflistfilter reflist maincursor
10163
10164 set top .showrefs
10165 set showrefstop $top
10166 if {[winfo exists $top]} {
10167 raise $top
10168 refill_reflist
10169 return
10170 }
10171 ttk_toplevel $top
10172 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
10173 make_transient $top .
10174 text $top.list -background $bgcolor -foreground $fgcolor \
10175 -selectbackground $selectbgcolor -font mainfont \
10176 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
10177 -width 60 -height 20 -cursor $maincursor \
10178 -spacing1 1 -spacing3 1 -state disabled
10179 $top.list tag configure highlight -background $selectbgcolor
10180 if {![lsearch -exact $bglist $top.list]} {
10181 lappend bglist $top.list
10182 lappend fglist $top.list
10183 }
10184 ttk::scrollbar $top.ysb -command "$top.list yview" -orient vertical
10185 ttk::scrollbar $top.xsb -command "$top.list xview" -orient horizontal
10186 grid $top.list $top.ysb -sticky nsew
10187 grid $top.xsb x -sticky ew
10188 ttk::frame $top.f
10189 ttk::label $top.f.l -text "[mc "Filter"]: "
10190 ttk::entry $top.f.e -width 20 -textvariable reflistfilter
10191 set reflistfilter "*"
10192 trace add variable reflistfilter write reflistfilter_change
10193 pack $top.f.e -side right -fill x -expand 1
10194 pack $top.f.l -side left
10195 grid $top.f - -sticky ew -pady 2
10196 ttk::checkbutton $top.sort -text [mc "Sort refs by type"] \
10197 -variable sortrefsbytype -command {refill_reflist}
10198 grid $top.sort - -sticky w -pady 2
10199 ttk::button $top.close -command [list destroy $top] -text [mc "Close"]
10200 bind $top <Key-Escape> [list destroy $top]
10201 grid $top.close -
10202 grid columnconfigure $top 0 -weight 1
10203 grid rowconfigure $top 0 -weight 1
10204 bind $top.list <1> {break}
10205 bind $top.list <B1-Motion> {break}
10206 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
10207 set reflist {}
10208 refill_reflist
10209}
10210
10211proc sel_reflist {w x y} {
10212 global showrefstop reflist headids tagids otherrefids
10213
10214 if {![winfo exists $showrefstop]} return
10215 set l [lindex [split [$w index "@$x,$y"] "."] 0]
10216 set ref [lindex $reflist [expr {$l-1}]]
10217 set n [lindex $ref 0]
10218 switch -- [lindex $ref 1] {
10219 "H" {selbyid $headids($n)}
10220 "R" {selbyid $headids($n)}
10221 "T" {selbyid $tagids($n)}
10222 "o" {selbyid $otherrefids($n)}
10223 }
10224 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
10225}
10226
10227proc unsel_reflist {} {
10228 global showrefstop
10229
10230 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
10231 $showrefstop.list tag remove highlight 0.0 end
10232}
10233
10234proc reflistfilter_change {n1 n2 op} {
10235 global reflistfilter
10236
10237 after cancel refill_reflist
10238 after 200 refill_reflist
10239}
10240
10241proc refill_reflist {} {
10242 global reflist reflistfilter showrefstop headids tagids otherrefids sortrefsbytype
10243 global curview upstreamofref
10244
10245 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
10246 set localrefs {}
10247 set remoterefs {}
10248 set trackedremoterefs {}
10249 set tagrefs {}
10250 set otherrefs {}
10251
10252 foreach n [array names headids] {
10253 if {![string match "remotes/*" $n] && [string match $reflistfilter $n]} {
10254 if {[commitinview $headids($n) $curview]} {
10255 lappend localrefs [list $n H]
10256 if {[info exists upstreamofref($n)] && \
10257 [info exists headids($upstreamofref($n))] && \
10258 [commitinview $headids($upstreamofref($n)) $curview]} {
10259 lappend trackedremoterefs [list $upstreamofref($n) R]
10260 }
10261 } else {
10262 interestedin $headids($n) {run refill_reflist}
10263 }
10264 }
10265 }
10266 set trackedremoterefs [lsort -index 0 -unique $trackedremoterefs]
10267 set localrefs [lsort -index 0 $localrefs]
10268
10269 foreach n [array names headids] {
10270 if {[string match "remotes/*" $n] && [string match $reflistfilter $n]} {
10271 if {[commitinview $headids($n) $curview]} {
10272 if {[lsearch -exact $trackedremoterefs [list $n R]] < 0} {
10273 lappend remoterefs [list $n R]
10274 }
10275 } else {
10276 interestedin $headids($n) {run refill_reflist}
10277 }
10278 }
10279 }
10280 set remoterefs [lsort -index 0 $remoterefs]
10281
10282 foreach n [array names tagids] {
10283 if {[string match $reflistfilter $n]} {
10284 if {[commitinview $tagids($n) $curview]} {
10285 lappend tagrefs [list $n T]
10286 } else {
10287 interestedin $tagids($n) {run refill_reflist}
10288 }
10289 }
10290 }
10291 set tagrefs [lsort -index 0 $tagrefs]
10292
10293 foreach n [array names otherrefids] {
10294 if {[string match $reflistfilter $n]} {
10295 if {[commitinview $otherrefids($n) $curview]} {
10296 lappend otherrefs [list "$n" o]
10297 } else {
10298 interestedin $otherrefids($n) {run refill_reflist}
10299 }
10300 }
10301 }
10302 set otherrefs [lsort -index 0 $otherrefs]
10303
10304 set refs [concat $localrefs $trackedremoterefs $remoterefs $tagrefs $otherrefs]
10305 if {!$sortrefsbytype} {
10306 set refs [lsort -index 0 $refs]
10307 }
10308
10309 if {$refs eq $reflist} return
10310
10311 # Update the contents of $showrefstop.list according to the
10312 # differences between $reflist (old) and $refs (new)
10313 $showrefstop.list conf -state normal
10314 $showrefstop.list insert end "\n"
10315 set i 0
10316 set j 0
10317 while {$i < [llength $reflist] || $j < [llength $refs]} {
10318 if {$i < [llength $reflist]} {
10319 if {$j < [llength $refs]} {
10320 set cmp [string compare [lindex $reflist $i 0] \
10321 [lindex $refs $j 0]]
10322 if {$cmp == 0} {
10323 set cmp [string compare [lindex $reflist $i 1] \
10324 [lindex $refs $j 1]]
10325 }
10326 } else {
10327 set cmp -1
10328 }
10329 } else {
10330 set cmp 1
10331 }
10332 switch -- $cmp {
10333 -1 {
10334 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
10335 incr i
10336 }
10337 0 {
10338 incr i
10339 incr j
10340 }
10341 1 {
10342 set l [expr {$j + 1}]
10343 $showrefstop.list image create $l.0 -align baseline \
10344 -image reficon-[lindex $refs $j 1] -padx 2
10345 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
10346 incr j
10347 }
10348 }
10349 }
10350 set reflist $refs
10351 # delete last newline
10352 $showrefstop.list delete end-2c end-1c
10353 $showrefstop.list conf -state disabled
10354}
10355
10356# Stuff for finding nearby tags
10357proc getallcommits {} {
10358 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
10359 global idheads idtags idotherrefs allparents tagobjid
10360 global gitdir
10361
10362 if {![info exists allcommits]} {
10363 set nextarc 0
10364 set allcommits 0
10365 set seeds {}
10366 set allcwait 0
10367 set cachedarcs 0
10368 set allccache [file join $gitdir "gitk.cache"]
10369 if {![catch {
10370 set f [safe_open_file $allccache r]
10371 set allcwait 1
10372 getcache $f
10373 }]} return
10374 }
10375
10376 if {$allcwait} {
10377 return
10378 }
10379 set cmd [list git rev-list --parents]
10380 set allcupdate [expr {$seeds ne {}}]
10381 if {!$allcupdate} {
10382 set ids "--all"
10383 } else {
10384 set refs [concat [array names idheads] [array names idtags] \
10385 [array names idotherrefs]]
10386 set ids {}
10387 set tagobjs {}
10388 foreach name [array names tagobjid] {
10389 lappend tagobjs $tagobjid($name)
10390 }
10391 foreach id [lsort -unique $refs] {
10392 if {![info exists allparents($id)] &&
10393 [lsearch -exact $tagobjs $id] < 0} {
10394 lappend ids $id
10395 }
10396 }
10397 if {$ids ne {}} {
10398 foreach id $seeds {
10399 lappend ids "^$id"
10400 }
10401 lappend ids "--"
10402 }
10403 }
10404 if {$ids ne {}} {
10405 if {$ids eq "--all"} {
10406 set cmd [concat $cmd "--all"]
10407 set fd [safe_open_command $cmd]
10408 } else {
10409 set cmd [concat $cmd --stdin]
10410 set fd [safe_open_command_redirect $cmd [list "<<[join $ids "\n"]"]]
10411 }
10412 fconfigure $fd -blocking 0
10413 incr allcommits
10414 nowbusy allcommits
10415 filerun $fd [list getallclines $fd]
10416 } else {
10417 dispneartags 0
10418 }
10419}
10420
10421# Since most commits have 1 parent and 1 child, we group strings of
10422# such commits into "arcs" joining branch/merge points (BMPs), which
10423# are commits that either don't have 1 parent or don't have 1 child.
10424#
10425# arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
10426# arcout(id) - outgoing arcs for BMP
10427# arcids(a) - list of IDs on arc including end but not start
10428# arcstart(a) - BMP ID at start of arc
10429# arcend(a) - BMP ID at end of arc
10430# growing(a) - arc a is still growing
10431# arctags(a) - IDs out of arcids (excluding end) that have tags
10432# archeads(a) - IDs out of arcids (excluding end) that have heads
10433# The start of an arc is at the descendent end, so "incoming" means
10434# coming from descendents, and "outgoing" means going towards ancestors.
10435
10436proc getallclines {fd} {
10437 global allparents allchildren idtags idheads nextarc
10438 global arcnos arcids arctags arcout arcend arcstart archeads growing
10439 global seeds allcommits cachedarcs allcupdate
10440
10441 set nid 0
10442 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
10443 set id [lindex $line 0]
10444 if {[info exists allparents($id)]} {
10445 # seen it already
10446 continue
10447 }
10448 set cachedarcs 0
10449 set olds [lrange $line 1 end]
10450 set allparents($id) $olds
10451 if {![info exists allchildren($id)]} {
10452 set allchildren($id) {}
10453 set arcnos($id) {}
10454 lappend seeds $id
10455 } else {
10456 set a $arcnos($id)
10457 if {[llength $olds] == 1 && [llength $a] == 1} {
10458 lappend arcids($a) $id
10459 if {[info exists idtags($id)]} {
10460 lappend arctags($a) $id
10461 }
10462 if {[info exists idheads($id)]} {
10463 lappend archeads($a) $id
10464 }
10465 if {[info exists allparents($olds)]} {
10466 # seen parent already
10467 if {![info exists arcout($olds)]} {
10468 splitarc $olds
10469 }
10470 lappend arcids($a) $olds
10471 set arcend($a) $olds
10472 unset growing($a)
10473 }
10474 lappend allchildren($olds) $id
10475 lappend arcnos($olds) $a
10476 continue
10477 }
10478 }
10479 foreach a $arcnos($id) {
10480 lappend arcids($a) $id
10481 set arcend($a) $id
10482 unset growing($a)
10483 }
10484
10485 set ao {}
10486 foreach p $olds {
10487 lappend allchildren($p) $id
10488 set a [incr nextarc]
10489 set arcstart($a) $id
10490 set archeads($a) {}
10491 set arctags($a) {}
10492 set archeads($a) {}
10493 set arcids($a) {}
10494 lappend ao $a
10495 set growing($a) 1
10496 if {[info exists allparents($p)]} {
10497 # seen it already, may need to make a new branch
10498 if {![info exists arcout($p)]} {
10499 splitarc $p
10500 }
10501 lappend arcids($a) $p
10502 set arcend($a) $p
10503 unset growing($a)
10504 }
10505 lappend arcnos($p) $a
10506 }
10507 set arcout($id) $ao
10508 }
10509 if {$nid > 0} {
10510 global cached_dheads cached_dtags cached_atags
10511 unset -nocomplain cached_dheads
10512 unset -nocomplain cached_dtags
10513 unset -nocomplain cached_atags
10514 }
10515 if {![eof $fd]} {
10516 return [expr {$nid >= 1000? 2: 1}]
10517 }
10518 set cacheok 1
10519 if {[catch {
10520 fconfigure $fd -blocking 1
10521 close $fd
10522 } err]} {
10523 # got an error reading the list of commits
10524 # if we were updating, try rereading the whole thing again
10525 if {$allcupdate} {
10526 incr allcommits -1
10527 dropcache $err
10528 return
10529 }
10530 error_popup "[mc "Error reading commit topology information;\
10531 branch and preceding/following tag information\
10532 will be incomplete."]\n($err)"
10533 set cacheok 0
10534 }
10535 if {[incr allcommits -1] == 0} {
10536 notbusy allcommits
10537 if {$cacheok} {
10538 run savecache
10539 }
10540 }
10541 dispneartags 0
10542 return 0
10543}
10544
10545proc recalcarc {a} {
10546 global arctags archeads arcids idtags idheads
10547
10548 set at {}
10549 set ah {}
10550 foreach id [lrange $arcids($a) 0 end-1] {
10551 if {[info exists idtags($id)]} {
10552 lappend at $id
10553 }
10554 if {[info exists idheads($id)]} {
10555 lappend ah $id
10556 }
10557 }
10558 set arctags($a) $at
10559 set archeads($a) $ah
10560}
10561
10562proc splitarc {p} {
10563 global arcnos arcids nextarc arctags archeads idtags idheads
10564 global arcstart arcend arcout allparents growing
10565
10566 set a $arcnos($p)
10567 if {[llength $a] != 1} {
10568 puts "oops splitarc called but [llength $a] arcs already"
10569 return
10570 }
10571 set a [lindex $a 0]
10572 set i [lsearch -exact $arcids($a) $p]
10573 if {$i < 0} {
10574 puts "oops splitarc $p not in arc $a"
10575 return
10576 }
10577 set na [incr nextarc]
10578 if {[info exists arcend($a)]} {
10579 set arcend($na) $arcend($a)
10580 } else {
10581 set l [lindex $allparents([lindex $arcids($a) end]) 0]
10582 set j [lsearch -exact $arcnos($l) $a]
10583 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
10584 }
10585 set tail [lrange $arcids($a) [expr {$i+1}] end]
10586 set arcids($a) [lrange $arcids($a) 0 $i]
10587 set arcend($a) $p
10588 set arcstart($na) $p
10589 set arcout($p) $na
10590 set arcids($na) $tail
10591 if {[info exists growing($a)]} {
10592 set growing($na) 1
10593 unset growing($a)
10594 }
10595
10596 foreach id $tail {
10597 if {[llength $arcnos($id)] == 1} {
10598 set arcnos($id) $na
10599 } else {
10600 set j [lsearch -exact $arcnos($id) $a]
10601 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
10602 }
10603 }
10604
10605 # reconstruct tags and heads lists
10606 if {$arctags($a) ne {} || $archeads($a) ne {}} {
10607 recalcarc $a
10608 recalcarc $na
10609 } else {
10610 set arctags($na) {}
10611 set archeads($na) {}
10612 }
10613}
10614
10615# Update things for a new commit added that is a child of one
10616# existing commit. Used when cherry-picking.
10617proc addnewchild {id p} {
10618 global allparents allchildren idtags nextarc
10619 global arcnos arcids arctags arcout arcend arcstart archeads growing
10620 global seeds allcommits
10621
10622 if {![info exists allcommits] || ![info exists arcnos($p)]} return
10623 set allparents($id) [list $p]
10624 set allchildren($id) {}
10625 set arcnos($id) {}
10626 lappend seeds $id
10627 lappend allchildren($p) $id
10628 set a [incr nextarc]
10629 set arcstart($a) $id
10630 set archeads($a) {}
10631 set arctags($a) {}
10632 set arcids($a) [list $p]
10633 set arcend($a) $p
10634 if {![info exists arcout($p)]} {
10635 splitarc $p
10636 }
10637 lappend arcnos($p) $a
10638 set arcout($id) [list $a]
10639}
10640
10641# This implements a cache for the topology information.
10642# The cache saves, for each arc, the start and end of the arc,
10643# the ids on the arc, and the outgoing arcs from the end.
10644proc readcache {f} {
10645 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
10646 global idtags idheads allparents cachedarcs possible_seeds seeds growing
10647 global allcwait
10648
10649 set a $nextarc
10650 set lim $cachedarcs
10651 if {$lim - $a > 500} {
10652 set lim [expr {$a + 500}]
10653 }
10654 if {[catch {
10655 if {$a == $lim} {
10656 # finish reading the cache and setting up arctags, etc.
10657 set line [gets $f]
10658 if {$line ne "1"} {error "bad final version"}
10659 close $f
10660 foreach id [array names idtags] {
10661 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10662 [llength $allparents($id)] == 1} {
10663 set a [lindex $arcnos($id) 0]
10664 if {$arctags($a) eq {}} {
10665 recalcarc $a
10666 }
10667 }
10668 }
10669 foreach id [array names idheads] {
10670 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
10671 [llength $allparents($id)] == 1} {
10672 set a [lindex $arcnos($id) 0]
10673 if {$archeads($a) eq {}} {
10674 recalcarc $a
10675 }
10676 }
10677 }
10678 foreach id [lsort -unique $possible_seeds] {
10679 if {$arcnos($id) eq {}} {
10680 lappend seeds $id
10681 }
10682 }
10683 set allcwait 0
10684 } else {
10685 while {[incr a] <= $lim} {
10686 set line [gets $f]
10687 if {[llength $line] != 3} {error "bad line"}
10688 set s [lindex $line 0]
10689 set arcstart($a) $s
10690 lappend arcout($s) $a
10691 if {![info exists arcnos($s)]} {
10692 lappend possible_seeds $s
10693 set arcnos($s) {}
10694 }
10695 set e [lindex $line 1]
10696 if {$e eq {}} {
10697 set growing($a) 1
10698 } else {
10699 set arcend($a) $e
10700 if {![info exists arcout($e)]} {
10701 set arcout($e) {}
10702 }
10703 }
10704 set arcids($a) [lindex $line 2]
10705 foreach id $arcids($a) {
10706 lappend allparents($s) $id
10707 set s $id
10708 lappend arcnos($id) $a
10709 }
10710 if {![info exists allparents($s)]} {
10711 set allparents($s) {}
10712 }
10713 set arctags($a) {}
10714 set archeads($a) {}
10715 }
10716 set nextarc [expr {$a - 1}]
10717 }
10718 } err]} {
10719 dropcache $err
10720 return 0
10721 }
10722 if {!$allcwait} {
10723 getallcommits
10724 }
10725 return $allcwait
10726}
10727
10728proc getcache {f} {
10729 global nextarc cachedarcs possible_seeds
10730
10731 if {[catch {
10732 set line [gets $f]
10733 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
10734 # make sure it's an integer
10735 set cachedarcs [expr {int([lindex $line 1])}]
10736 if {$cachedarcs < 0} {error "bad number of arcs"}
10737 set nextarc 0
10738 set possible_seeds {}
10739 run readcache $f
10740 } err]} {
10741 dropcache $err
10742 }
10743 return 0
10744}
10745
10746proc dropcache {err} {
10747 global allcwait nextarc cachedarcs seeds
10748
10749 #puts "dropping cache ($err)"
10750 foreach v {arcnos arcout arcids arcstart arcend growing \
10751 arctags archeads allparents allchildren} {
10752 global $v
10753 unset -nocomplain $v
10754 }
10755 set allcwait 0
10756 set nextarc 0
10757 set cachedarcs 0
10758 set seeds {}
10759 getallcommits
10760}
10761
10762proc writecache {f} {
10763 global cachearc cachedarcs allccache
10764 global arcstart arcend arcnos arcids arcout
10765
10766 set a $cachearc
10767 set lim $cachedarcs
10768 if {$lim - $a > 1000} {
10769 set lim [expr {$a + 1000}]
10770 }
10771 if {[catch {
10772 while {[incr a] <= $lim} {
10773 if {[info exists arcend($a)]} {
10774 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
10775 } else {
10776 puts $f [list $arcstart($a) {} $arcids($a)]
10777 }
10778 }
10779 } err]} {
10780 catch {close $f}
10781 catch {file delete $allccache}
10782 #puts "writing cache failed ($err)"
10783 return 0
10784 }
10785 set cachearc [expr {$a - 1}]
10786 if {$a > $cachedarcs} {
10787 puts $f "1"
10788 close $f
10789 return 0
10790 }
10791 return 1
10792}
10793
10794proc savecache {} {
10795 global nextarc cachedarcs cachearc allccache
10796
10797 if {$nextarc == $cachedarcs} return
10798 set cachearc 0
10799 set cachedarcs $nextarc
10800 catch {
10801 set f [safe_open_file $allccache w]
10802 puts $f [list 1 $cachedarcs]
10803 run writecache $f
10804 }
10805}
10806
10807# Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
10808# or 0 if neither is true.
10809proc anc_or_desc {a b} {
10810 global arcout arcstart arcend arcnos cached_isanc
10811
10812 if {$arcnos($a) eq $arcnos($b)} {
10813 # Both are on the same arc(s); either both are the same BMP,
10814 # or if one is not a BMP, the other is also not a BMP or is
10815 # the BMP at end of the arc (and it only has 1 incoming arc).
10816 # Or both can be BMPs with no incoming arcs.
10817 if {$a eq $b || $arcnos($a) eq {}} {
10818 return 0
10819 }
10820 # assert {[llength $arcnos($a)] == 1}
10821 set arc [lindex $arcnos($a) 0]
10822 set i [lsearch -exact $arcids($arc) $a]
10823 set j [lsearch -exact $arcids($arc) $b]
10824 if {$i < 0 || $i > $j} {
10825 return 1
10826 } else {
10827 return -1
10828 }
10829 }
10830
10831 if {![info exists arcout($a)]} {
10832 set arc [lindex $arcnos($a) 0]
10833 if {[info exists arcend($arc)]} {
10834 set aend $arcend($arc)
10835 } else {
10836 set aend {}
10837 }
10838 set a $arcstart($arc)
10839 } else {
10840 set aend $a
10841 }
10842 if {![info exists arcout($b)]} {
10843 set arc [lindex $arcnos($b) 0]
10844 if {[info exists arcend($arc)]} {
10845 set bend $arcend($arc)
10846 } else {
10847 set bend {}
10848 }
10849 set b $arcstart($arc)
10850 } else {
10851 set bend $b
10852 }
10853 if {$a eq $bend} {
10854 return 1
10855 }
10856 if {$b eq $aend} {
10857 return -1
10858 }
10859 if {[info exists cached_isanc($a,$bend)]} {
10860 if {$cached_isanc($a,$bend)} {
10861 return 1
10862 }
10863 }
10864 if {[info exists cached_isanc($b,$aend)]} {
10865 if {$cached_isanc($b,$aend)} {
10866 return -1
10867 }
10868 if {[info exists cached_isanc($a,$bend)]} {
10869 return 0
10870 }
10871 }
10872
10873 set todo [list $a $b]
10874 set anc($a) a
10875 set anc($b) b
10876 for {set i 0} {$i < [llength $todo]} {incr i} {
10877 set x [lindex $todo $i]
10878 if {$anc($x) eq {}} {
10879 continue
10880 }
10881 foreach arc $arcnos($x) {
10882 set xd $arcstart($arc)
10883 if {$xd eq $bend} {
10884 set cached_isanc($a,$bend) 1
10885 set cached_isanc($b,$aend) 0
10886 return 1
10887 } elseif {$xd eq $aend} {
10888 set cached_isanc($b,$aend) 1
10889 set cached_isanc($a,$bend) 0
10890 return -1
10891 }
10892 if {![info exists anc($xd)]} {
10893 set anc($xd) $anc($x)
10894 lappend todo $xd
10895 } elseif {$anc($xd) ne $anc($x)} {
10896 set anc($xd) {}
10897 }
10898 }
10899 }
10900 set cached_isanc($a,$bend) 0
10901 set cached_isanc($b,$aend) 0
10902 return 0
10903}
10904
10905# This identifies whether $desc has an ancestor that is
10906# a growing tip of the graph and which is not an ancestor of $anc
10907# and returns 0 if so and 1 if not.
10908# If we subsequently discover a tag on such a growing tip, and that
10909# turns out to be a descendent of $anc (which it could, since we
10910# don't necessarily see children before parents), then $desc
10911# isn't a good choice to display as a descendent tag of
10912# $anc (since it is the descendent of another tag which is
10913# a descendent of $anc). Similarly, $anc isn't a good choice to
10914# display as a ancestor tag of $desc.
10915#
10916proc is_certain {desc anc} {
10917 global arcnos arcout arcstart arcend growing problems
10918
10919 set certain {}
10920 if {[llength $arcnos($anc)] == 1} {
10921 # tags on the same arc are certain
10922 if {$arcnos($desc) eq $arcnos($anc)} {
10923 return 1
10924 }
10925 if {![info exists arcout($anc)]} {
10926 # if $anc is partway along an arc, use the start of the arc instead
10927 set a [lindex $arcnos($anc) 0]
10928 set anc $arcstart($a)
10929 }
10930 }
10931 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
10932 set x $desc
10933 } else {
10934 set a [lindex $arcnos($desc) 0]
10935 set x $arcend($a)
10936 }
10937 if {$x == $anc} {
10938 return 1
10939 }
10940 set anclist [list $x]
10941 set dl($x) 1
10942 set nnh 1
10943 set ngrowanc 0
10944 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
10945 set x [lindex $anclist $i]
10946 if {$dl($x)} {
10947 incr nnh -1
10948 }
10949 set done($x) 1
10950 foreach a $arcout($x) {
10951 if {[info exists growing($a)]} {
10952 if {![info exists growanc($x)] && $dl($x)} {
10953 set growanc($x) 1
10954 incr ngrowanc
10955 }
10956 } else {
10957 set y $arcend($a)
10958 if {[info exists dl($y)]} {
10959 if {$dl($y)} {
10960 if {!$dl($x)} {
10961 set dl($y) 0
10962 if {![info exists done($y)]} {
10963 incr nnh -1
10964 }
10965 if {[info exists growanc($x)]} {
10966 incr ngrowanc -1
10967 }
10968 set xl [list $y]
10969 for {set k 0} {$k < [llength $xl]} {incr k} {
10970 set z [lindex $xl $k]
10971 foreach c $arcout($z) {
10972 if {[info exists arcend($c)]} {
10973 set v $arcend($c)
10974 if {[info exists dl($v)] && $dl($v)} {
10975 set dl($v) 0
10976 if {![info exists done($v)]} {
10977 incr nnh -1
10978 }
10979 if {[info exists growanc($v)]} {
10980 incr ngrowanc -1
10981 }
10982 lappend xl $v
10983 }
10984 }
10985 }
10986 }
10987 }
10988 }
10989 } elseif {$y eq $anc || !$dl($x)} {
10990 set dl($y) 0
10991 lappend anclist $y
10992 } else {
10993 set dl($y) 1
10994 lappend anclist $y
10995 incr nnh
10996 }
10997 }
10998 }
10999 }
11000 foreach x [array names growanc] {
11001 if {$dl($x)} {
11002 return 0
11003 }
11004 return 0
11005 }
11006 return 1
11007}
11008
11009proc validate_arctags {a} {
11010 global arctags idtags
11011
11012 set i -1
11013 set na $arctags($a)
11014 foreach id $arctags($a) {
11015 incr i
11016 if {![info exists idtags($id)]} {
11017 set na [lreplace $na $i $i]
11018 incr i -1
11019 }
11020 }
11021 set arctags($a) $na
11022}
11023
11024proc validate_archeads {a} {
11025 global archeads idheads
11026
11027 set i -1
11028 set na $archeads($a)
11029 foreach id $archeads($a) {
11030 incr i
11031 if {![info exists idheads($id)]} {
11032 set na [lreplace $na $i $i]
11033 incr i -1
11034 }
11035 }
11036 set archeads($a) $na
11037}
11038
11039# Return the list of IDs that have tags that are descendents of id,
11040# ignoring IDs that are descendents of IDs already reported.
11041proc desctags {id} {
11042 global arcnos arcstart arcids arctags idtags allparents
11043 global growing cached_dtags
11044
11045 if {![info exists allparents($id)]} {
11046 return {}
11047 }
11048 set t1 [clock clicks -milliseconds]
11049 set argid $id
11050 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
11051 # part-way along an arc; check that arc first
11052 set a [lindex $arcnos($id) 0]
11053 if {$arctags($a) ne {}} {
11054 validate_arctags $a
11055 set i [lsearch -exact $arcids($a) $id]
11056 set tid {}
11057 foreach t $arctags($a) {
11058 set j [lsearch -exact $arcids($a) $t]
11059 if {$j >= $i} break
11060 set tid $t
11061 }
11062 if {$tid ne {}} {
11063 return $tid
11064 }
11065 }
11066 set id $arcstart($a)
11067 if {[info exists idtags($id)]} {
11068 return $id
11069 }
11070 }
11071 if {[info exists cached_dtags($id)]} {
11072 return $cached_dtags($id)
11073 }
11074
11075 set origid $id
11076 set todo [list $id]
11077 set queued($id) 1
11078 set nc 1
11079 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
11080 set id [lindex $todo $i]
11081 set done($id) 1
11082 set ta [info exists hastaggedancestor($id)]
11083 if {!$ta} {
11084 incr nc -1
11085 }
11086 # ignore tags on starting node
11087 if {!$ta && $i > 0} {
11088 if {[info exists idtags($id)]} {
11089 set tagloc($id) $id
11090 set ta 1
11091 } elseif {[info exists cached_dtags($id)]} {
11092 set tagloc($id) $cached_dtags($id)
11093 set ta 1
11094 }
11095 }
11096 foreach a $arcnos($id) {
11097 set d $arcstart($a)
11098 if {!$ta && $arctags($a) ne {}} {
11099 validate_arctags $a
11100 if {$arctags($a) ne {}} {
11101 lappend tagloc($id) [lindex $arctags($a) end]
11102 }
11103 }
11104 if {$ta || $arctags($a) ne {}} {
11105 set tomark [list $d]
11106 for {set j 0} {$j < [llength $tomark]} {incr j} {
11107 set dd [lindex $tomark $j]
11108 if {![info exists hastaggedancestor($dd)]} {
11109 if {[info exists done($dd)]} {
11110 foreach b $arcnos($dd) {
11111 lappend tomark $arcstart($b)
11112 }
11113 if {[info exists tagloc($dd)]} {
11114 unset tagloc($dd)
11115 }
11116 } elseif {[info exists queued($dd)]} {
11117 incr nc -1
11118 }
11119 set hastaggedancestor($dd) 1
11120 }
11121 }
11122 }
11123 if {![info exists queued($d)]} {
11124 lappend todo $d
11125 set queued($d) 1
11126 if {![info exists hastaggedancestor($d)]} {
11127 incr nc
11128 }
11129 }
11130 }
11131 }
11132 set tags {}
11133 foreach id [array names tagloc] {
11134 if {![info exists hastaggedancestor($id)]} {
11135 foreach t $tagloc($id) {
11136 if {[lsearch -exact $tags $t] < 0} {
11137 lappend tags $t
11138 }
11139 }
11140 }
11141 }
11142 set t2 [clock clicks -milliseconds]
11143 set loopix $i
11144
11145 # remove tags that are descendents of other tags
11146 for {set i 0} {$i < [llength $tags]} {incr i} {
11147 set a [lindex $tags $i]
11148 for {set j 0} {$j < $i} {incr j} {
11149 set b [lindex $tags $j]
11150 set r [anc_or_desc $a $b]
11151 if {$r == 1} {
11152 set tags [lreplace $tags $j $j]
11153 incr j -1
11154 incr i -1
11155 } elseif {$r == -1} {
11156 set tags [lreplace $tags $i $i]
11157 incr i -1
11158 break
11159 }
11160 }
11161 }
11162
11163 if {[array names growing] ne {}} {
11164 # graph isn't finished, need to check if any tag could get
11165 # eclipsed by another tag coming later. Simply ignore any
11166 # tags that could later get eclipsed.
11167 set ctags {}
11168 foreach t $tags {
11169 if {[is_certain $t $origid]} {
11170 lappend ctags $t
11171 }
11172 }
11173 if {$tags eq $ctags} {
11174 set cached_dtags($origid) $tags
11175 } else {
11176 set tags $ctags
11177 }
11178 } else {
11179 set cached_dtags($origid) $tags
11180 }
11181 set t3 [clock clicks -milliseconds]
11182 if {0 && $t3 - $t1 >= 100} {
11183 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
11184 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
11185 }
11186 return $tags
11187}
11188
11189proc anctags {id} {
11190 global arcnos arcids arcout arcend arctags idtags allparents
11191 global growing cached_atags
11192
11193 if {![info exists allparents($id)]} {
11194 return {}
11195 }
11196 set t1 [clock clicks -milliseconds]
11197 set argid $id
11198 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
11199 # part-way along an arc; check that arc first
11200 set a [lindex $arcnos($id) 0]
11201 if {$arctags($a) ne {}} {
11202 validate_arctags $a
11203 set i [lsearch -exact $arcids($a) $id]
11204 foreach t $arctags($a) {
11205 set j [lsearch -exact $arcids($a) $t]
11206 if {$j > $i} {
11207 return $t
11208 }
11209 }
11210 }
11211 if {![info exists arcend($a)]} {
11212 return {}
11213 }
11214 set id $arcend($a)
11215 if {[info exists idtags($id)]} {
11216 return $id
11217 }
11218 }
11219 if {[info exists cached_atags($id)]} {
11220 return $cached_atags($id)
11221 }
11222
11223 set origid $id
11224 set todo [list $id]
11225 set queued($id) 1
11226 set taglist {}
11227 set nc 1
11228 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
11229 set id [lindex $todo $i]
11230 set done($id) 1
11231 set td [info exists hastaggeddescendent($id)]
11232 if {!$td} {
11233 incr nc -1
11234 }
11235 # ignore tags on starting node
11236 if {!$td && $i > 0} {
11237 if {[info exists idtags($id)]} {
11238 set tagloc($id) $id
11239 set td 1
11240 } elseif {[info exists cached_atags($id)]} {
11241 set tagloc($id) $cached_atags($id)
11242 set td 1
11243 }
11244 }
11245 foreach a $arcout($id) {
11246 if {!$td && $arctags($a) ne {}} {
11247 validate_arctags $a
11248 if {$arctags($a) ne {}} {
11249 lappend tagloc($id) [lindex $arctags($a) 0]
11250 }
11251 }
11252 if {![info exists arcend($a)]} continue
11253 set d $arcend($a)
11254 if {$td || $arctags($a) ne {}} {
11255 set tomark [list $d]
11256 for {set j 0} {$j < [llength $tomark]} {incr j} {
11257 set dd [lindex $tomark $j]
11258 if {![info exists hastaggeddescendent($dd)]} {
11259 if {[info exists done($dd)]} {
11260 foreach b $arcout($dd) {
11261 if {[info exists arcend($b)]} {
11262 lappend tomark $arcend($b)
11263 }
11264 }
11265 if {[info exists tagloc($dd)]} {
11266 unset tagloc($dd)
11267 }
11268 } elseif {[info exists queued($dd)]} {
11269 incr nc -1
11270 }
11271 set hastaggeddescendent($dd) 1
11272 }
11273 }
11274 }
11275 if {![info exists queued($d)]} {
11276 lappend todo $d
11277 set queued($d) 1
11278 if {![info exists hastaggeddescendent($d)]} {
11279 incr nc
11280 }
11281 }
11282 }
11283 }
11284 set t2 [clock clicks -milliseconds]
11285 set loopix $i
11286 set tags {}
11287 foreach id [array names tagloc] {
11288 if {![info exists hastaggeddescendent($id)]} {
11289 foreach t $tagloc($id) {
11290 if {[lsearch -exact $tags $t] < 0} {
11291 lappend tags $t
11292 }
11293 }
11294 }
11295 }
11296
11297 # remove tags that are ancestors of other tags
11298 for {set i 0} {$i < [llength $tags]} {incr i} {
11299 set a [lindex $tags $i]
11300 for {set j 0} {$j < $i} {incr j} {
11301 set b [lindex $tags $j]
11302 set r [anc_or_desc $a $b]
11303 if {$r == -1} {
11304 set tags [lreplace $tags $j $j]
11305 incr j -1
11306 incr i -1
11307 } elseif {$r == 1} {
11308 set tags [lreplace $tags $i $i]
11309 incr i -1
11310 break
11311 }
11312 }
11313 }
11314
11315 if {[array names growing] ne {}} {
11316 # graph isn't finished, need to check if any tag could get
11317 # eclipsed by another tag coming later. Simply ignore any
11318 # tags that could later get eclipsed.
11319 set ctags {}
11320 foreach t $tags {
11321 if {[is_certain $origid $t]} {
11322 lappend ctags $t
11323 }
11324 }
11325 if {$tags eq $ctags} {
11326 set cached_atags($origid) $tags
11327 } else {
11328 set tags $ctags
11329 }
11330 } else {
11331 set cached_atags($origid) $tags
11332 }
11333 set t3 [clock clicks -milliseconds]
11334 if {0 && $t3 - $t1 >= 100} {
11335 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
11336 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
11337 }
11338 return $tags
11339}
11340
11341# Return the list of IDs that have heads that are descendents of id,
11342# including id itself if it has a head.
11343proc descheads {id} {
11344 global arcnos arcstart arcids archeads idheads cached_dheads
11345 global allparents arcout
11346
11347 if {![info exists allparents($id)]} {
11348 return {}
11349 }
11350 set aret {}
11351 if {![info exists arcout($id)]} {
11352 # part-way along an arc; check it first
11353 set a [lindex $arcnos($id) 0]
11354 if {$archeads($a) ne {}} {
11355 validate_archeads $a
11356 set i [lsearch -exact $arcids($a) $id]
11357 foreach t $archeads($a) {
11358 set j [lsearch -exact $arcids($a) $t]
11359 if {$j > $i} break
11360 lappend aret $t
11361 }
11362 }
11363 set id $arcstart($a)
11364 }
11365 set origid $id
11366 set todo [list $id]
11367 set seen($id) 1
11368 set ret {}
11369 for {set i 0} {$i < [llength $todo]} {incr i} {
11370 set id [lindex $todo $i]
11371 if {[info exists cached_dheads($id)]} {
11372 set ret [concat $ret $cached_dheads($id)]
11373 } else {
11374 if {[info exists idheads($id)]} {
11375 lappend ret $id
11376 }
11377 foreach a $arcnos($id) {
11378 if {$archeads($a) ne {}} {
11379 validate_archeads $a
11380 if {$archeads($a) ne {}} {
11381 set ret [concat $ret $archeads($a)]
11382 }
11383 }
11384 set d $arcstart($a)
11385 if {![info exists seen($d)]} {
11386 lappend todo $d
11387 set seen($d) 1
11388 }
11389 }
11390 }
11391 }
11392 set ret [lsort -unique $ret]
11393 set cached_dheads($origid) $ret
11394 return [concat $ret $aret]
11395}
11396
11397proc addedtag {id} {
11398 global arcnos arcout cached_dtags cached_atags
11399
11400 if {![info exists arcnos($id)]} return
11401 if {![info exists arcout($id)]} {
11402 recalcarc [lindex $arcnos($id) 0]
11403 }
11404 unset -nocomplain cached_dtags
11405 unset -nocomplain cached_atags
11406}
11407
11408proc addedhead {hid head} {
11409 global arcnos arcout cached_dheads
11410
11411 if {![info exists arcnos($hid)]} return
11412 if {![info exists arcout($hid)]} {
11413 recalcarc [lindex $arcnos($hid) 0]
11414 }
11415 unset -nocomplain cached_dheads
11416}
11417
11418proc removedhead {hid head} {
11419 global cached_dheads
11420
11421 unset -nocomplain cached_dheads
11422}
11423
11424proc movedhead {hid head} {
11425 global arcnos arcout cached_dheads
11426
11427 if {![info exists arcnos($hid)]} return
11428 if {![info exists arcout($hid)]} {
11429 recalcarc [lindex $arcnos($hid) 0]
11430 }
11431 unset -nocomplain cached_dheads
11432}
11433
11434proc changedrefs {} {
11435 global cached_dheads cached_dtags cached_atags cached_tagcontent
11436 global arctags archeads arcnos arcout idheads idtags
11437
11438 foreach id [concat [array names idheads] [array names idtags]] {
11439 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
11440 set a [lindex $arcnos($id) 0]
11441 if {![info exists donearc($a)]} {
11442 recalcarc $a
11443 set donearc($a) 1
11444 }
11445 }
11446 }
11447 unset -nocomplain cached_tagcontent
11448 unset -nocomplain cached_dtags
11449 unset -nocomplain cached_atags
11450 unset -nocomplain cached_dheads
11451}
11452
11453proc rereadrefs {} {
11454 global idtags idheads idotherrefs mainheadid
11455
11456 set refids [concat [array names idtags] \
11457 [array names idheads] [array names idotherrefs]]
11458 foreach id $refids {
11459 if {![info exists ref($id)]} {
11460 set ref($id) [listrefs $id]
11461 }
11462 }
11463 set oldmainhead $mainheadid
11464 readrefs
11465 changedrefs
11466 set refids [lsort -unique [concat $refids [array names idtags] \
11467 [array names idheads] [array names idotherrefs]]]
11468 foreach id $refids {
11469 set v [listrefs $id]
11470 if {![info exists ref($id)] || $ref($id) != $v} {
11471 redrawtags $id
11472 }
11473 }
11474 if {$oldmainhead ne $mainheadid} {
11475 redrawtags $oldmainhead
11476 redrawtags $mainheadid
11477 }
11478 run refill_reflist
11479}
11480
11481proc listrefs {id} {
11482 global idtags idheads idotherrefs
11483
11484 set x {}
11485 if {[info exists idtags($id)]} {
11486 set x $idtags($id)
11487 }
11488 set y {}
11489 if {[info exists idheads($id)]} {
11490 set y $idheads($id)
11491 }
11492 set z {}
11493 if {[info exists idotherrefs($id)]} {
11494 set z $idotherrefs($id)
11495 }
11496 return [list $x $y $z]
11497}
11498
11499proc add_tag_ctext {tag} {
11500 global ctext cached_tagcontent tagids
11501
11502 if {![info exists cached_tagcontent($tag)]} {
11503 catch {
11504 set cached_tagcontent($tag) [safe_exec [list git cat-file -p $tag]]
11505 }
11506 }
11507 $ctext insert end "[mc "Tag"]: $tag\n" bold
11508 if {[info exists cached_tagcontent($tag)]} {
11509 set text $cached_tagcontent($tag)
11510 } else {
11511 set text "[mc "Id"]: $tagids($tag)"
11512 }
11513 appendwithlinks $text {}
11514}
11515
11516proc showtag {tag isnew} {
11517 global ctext cached_tagcontent tagids linknum tagobjid
11518
11519 if {$isnew} {
11520 addtohistory [list showtag $tag 0] savectextpos
11521 }
11522 $ctext conf -state normal
11523 clear_ctext
11524 settabs 0
11525 set linknum 0
11526 add_tag_ctext $tag
11527 maybe_scroll_ctext 1
11528 $ctext conf -state disabled
11529 init_flist {}
11530}
11531
11532proc showtags {id isnew} {
11533 global idtags ctext linknum
11534
11535 if {$isnew} {
11536 addtohistory [list showtags $id 0] savectextpos
11537 }
11538 $ctext conf -state normal
11539 clear_ctext
11540 settabs 0
11541 set linknum 0
11542 set sep {}
11543 foreach tag $idtags($id) {
11544 $ctext insert end $sep
11545 add_tag_ctext $tag
11546 set sep "\n\n"
11547 }
11548 maybe_scroll_ctext 1
11549 $ctext conf -state disabled
11550 init_flist {}
11551}
11552
11553proc doquit {} {
11554 global stopped
11555 global gitktmpdir
11556
11557 set stopped 100
11558 savestuff .
11559 destroy .
11560
11561 if {[info exists gitktmpdir]} {
11562 catch {file delete -force $gitktmpdir}
11563 }
11564}
11565
11566proc mkfontdisp {font top which} {
11567 global fontattr fontpref $font
11568
11569 set fontpref($font) [set $font]
11570 ttk::button $top.${font}but -text $which \
11571 -command [list choosefont $font $which]
11572 ttk::label $top.$font -font $font \
11573 -text $fontattr($font,family)
11574 grid x $top.${font}but $top.$font -sticky w
11575 grid configure $top.$font -sticky ew
11576}
11577
11578proc centertext {w} {
11579 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
11580}
11581
11582proc fontok {} {
11583 global fontparam fontpref prefstop
11584
11585 set f $fontparam(font)
11586 set fontpref($f) [list $fontparam(family) $fontparam(size)]
11587 if {$fontparam(weight) eq "bold"} {
11588 lappend fontpref($f) "bold"
11589 }
11590 if {$fontparam(slant) eq "italic"} {
11591 lappend fontpref($f) "italic"
11592 }
11593 set w $prefstop.notebook.fonts.$f
11594 $w conf -text $fontparam(family) -font $fontpref($f)
11595
11596 fontcan
11597}
11598
11599proc fontcan {} {
11600 global fonttop fontparam
11601
11602 if {[info exists fonttop]} {
11603 catch {destroy $fonttop}
11604 catch {font delete sample}
11605 unset fonttop
11606 unset fontparam
11607 }
11608}
11609
11610proc choosefont {font which} {
11611 tk fontchooser configure -title $which -font $font \
11612 -command [list on_choosefont $font $which]
11613 tk fontchooser show
11614}
11615proc on_choosefont {font which newfont} {
11616 global fontparam
11617 array set f [font actual $newfont]
11618 set fontparam(which) $which
11619 set fontparam(font) $font
11620 set fontparam(family) $f(-family)
11621 set fontparam(size) $f(-size)
11622 set fontparam(weight) $f(-weight)
11623 set fontparam(slant) $f(-slant)
11624 fontok
11625}
11626
11627proc selfontfam {} {
11628 global fonttop fontparam
11629
11630 set i [$fonttop.f.fam curselection]
11631 if {$i ne {}} {
11632 set fontparam(family) [$fonttop.f.fam get $i]
11633 }
11634}
11635
11636proc chg_fontparam {v sub op} {
11637 global fontparam
11638
11639 font config sample -$sub $fontparam($sub)
11640}
11641
11642# Create a property sheet tab page
11643proc create_prefs_page {w} {
11644 ttk::frame $w
11645}
11646
11647proc prefspage_general {notebook} {
11648 global {*}$::config_variables
11649 global hashlength
11650
11651 set page [create_prefs_page $notebook.general]
11652
11653 ttk::label $page.ldisp -text [mc "Commit list display options"] -font mainfontbold
11654 grid $page.ldisp - -sticky w -pady 10
11655
11656 ttk::label $page.spacer -text " "
11657 ttk::label $page.maxwidthl -text [mc "Maximum graph width (lines)"]
11658 ttk::spinbox $page.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
11659 grid $page.spacer $page.maxwidthl $page.maxwidth -sticky w
11660 #xgettext:no-tcl-format
11661 ttk::label $page.maxpctl -text [mc "Maximum graph width (% of pane)"]
11662 ttk::spinbox $page.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
11663 grid x $page.maxpctl $page.maxpct -sticky w
11664
11665 ttk::checkbutton $page.showlocal -text [mc "Show local changes"] \
11666 -variable showlocalchanges
11667 grid x $page.showlocal -sticky w
11668
11669 ttk::checkbutton $page.hideremotes -text [mc "Hide remote refs"] \
11670 -variable hideremotes
11671 grid x $page.hideremotes -sticky w
11672
11673 ttk::entry $page.refstohide -textvariable refstohide
11674 ttk::label $page.refstohidel -text [mc "Refs to hide (space-separated globs)"]
11675 grid x $page.refstohidel $page.refstohide -sticky ew
11676 grid configure $page.refstohide -padx {0 5}
11677
11678 ttk::checkbutton $page.autocopy -text [mc "Copy commit ID to clipboard"] \
11679 -variable autocopy
11680 grid x $page.autocopy -sticky w
11681
11682 if {[haveselectionclipboard]} {
11683 ttk::checkbutton $page.autoselect -text [mc "Copy commit ID to X11 selection"] \
11684 -variable autoselect
11685 grid x $page.autoselect -sticky w
11686 }
11687
11688 ttk::spinbox $page.autosellen -from 1 -to $hashlength -width 4 -textvariable autosellen
11689 ttk::label $page.autosellenl -text [mc "Length of commit ID to copy"]
11690 grid x $page.autosellenl $page.autosellen -sticky w
11691
11692 ttk::label $page.kscroll1 -text [mc "Wheel scrolling multiplier"]
11693 ttk::spinbox $page.kscroll -from 1 -to 20 -width 4 -textvariable kscroll
11694 grid x $page.kscroll1 $page.kscroll -sticky w
11695
11696 ttk::label $page.ddisp -text [mc "Diff display options"] -font mainfontbold
11697 grid $page.ddisp - -sticky w -pady 10
11698
11699 ttk::label $page.tabstopl -text [mc "Tab spacing"]
11700 ttk::spinbox $page.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
11701 grid x $page.tabstopl $page.tabstop -sticky w
11702
11703 ttk::label $page.wrapcommentl -text [mc "Wrap comment text"]
11704 makedroplist $page.wrapcomment wrapcomment none char word
11705 grid x $page.wrapcommentl $page.wrapcomment -sticky w
11706
11707 ttk::label $page.wrapdefaultl -text [mc "Wrap other text"]
11708 makedroplist $page.wrapdefault wrapdefault none char word
11709 grid x $page.wrapdefaultl $page.wrapdefault -sticky w
11710
11711 ttk::checkbutton $page.ntag -text [mc "Display nearby tags/heads"] \
11712 -variable showneartags
11713 grid x $page.ntag -sticky w
11714
11715 ttk::label $page.maxrefsl -text [mc "Maximum # tags/heads to show"]
11716 ttk::spinbox $page.maxrefs -from 1 -to 1000 -width 4 -textvariable maxrefs
11717 grid x $page.maxrefsl $page.maxrefs -sticky w
11718
11719 ttk::checkbutton $page.ldiff -text [mc "Limit diffs to listed paths"] \
11720 -variable limitdiffs
11721 grid x $page.ldiff -sticky w
11722
11723 ttk::checkbutton $page.lattr -text [mc "Support per-file encodings"] \
11724 -variable perfile_attrs
11725 grid x $page.lattr -sticky w
11726
11727 ttk::entry $page.extdifft -textvariable extdifftool
11728 ttk::frame $page.extdifff
11729 ttk::label $page.extdifff.l -text [mc "External diff tool" ]
11730 ttk::button $page.extdifff.b -text [mc "Choose..."] -command choose_extdiff
11731 pack $page.extdifff.l -side left
11732 pack $page.extdifff.b -side right -padx {0 5}
11733 grid x $page.extdifff $page.extdifft -sticky ew
11734 grid configure $page.extdifft -padx {0 5}
11735
11736 ttk::entry $page.webbrowser -textvariable web_browser
11737 ttk::label $page.webbrowserl -text [mc "Web browser" ]
11738 grid x $page.webbrowserl $page.webbrowser -sticky ew
11739 grid configure $page.webbrowser -padx {0 5}
11740
11741 grid columnconfigure $page 2 -weight 1
11742
11743 return $page
11744}
11745
11746proc prefspage_colors {notebook} {
11747 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11748 global diffbgcolors
11749 global themeloader
11750
11751 set page [create_prefs_page $notebook.colors]
11752
11753 ttk::label $page.themesel -font mainfontbold \
11754 -text [mc "Themes - change requires restart"]
11755 grid $page.themesel - -sticky w -pady 10
11756
11757 ttk::label $page.themelabel -text [mc "Theme to use after restart"]
11758 makedroplist $page.theme theme {*}[lsort [ttk::style theme names]]
11759 grid x $page.themelabel $page.theme -sticky w
11760
11761 ttk::entry $page.tloadvar -textvariable themeloader
11762 ttk::frame $page.tloadframe
11763 ttk::label $page.tloadframe.l -text [mc "Theme definition file"]
11764 ttk::button $page.tloadframe.b -text [mc "Choose..."] \
11765 -command [list choose_themeloader $page]
11766 pack $page.tloadframe.l -side left
11767 pack $page.tloadframe.b -side right -padx {0 5}
11768 pack configure $page.tloadframe.l -padx 0
11769 grid x $page.tloadframe $page.tloadvar -sticky ew
11770 grid configure $page.tloadvar -padx {0 5}
11771
11772 ttk::label $page.themelabel2 -text \
11773 [mc "The theme definition file may affect all themes."]
11774 ttk::button $page.themebut2 -text [mc "Apply theme"] \
11775 -command [list updatetheme $page]
11776 grid x $page.themebut2 $page.themelabel2 -sticky w
11777
11778 ttk::label $page.cdisp -text [mc "Colors: press to choose"] -font mainfontbold
11779 grid $page.cdisp - -sticky w -pady 10
11780 label $page.bg -padx 40 -relief sunk -background $bgcolor
11781 ttk::button $page.bgbut -text [mc "Background"] \
11782 -command [list choosecolor bgcolor {} $page [mc "background"]]
11783 grid x $page.bgbut $page.bg -sticky w
11784
11785 label $page.fg -padx 40 -relief sunk -background $fgcolor
11786 ttk::button $page.fgbut -text [mc "Foreground"] \
11787 -command [list choosecolor fgcolor {} $page [mc "foreground"]]
11788 grid x $page.fgbut $page.fg -sticky w
11789
11790 label $page.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
11791 ttk::button $page.diffoldbut -text [mc "Diff: old lines"] \
11792 -command [list choosecolor diffcolors 0 $page [mc "diff old lines"]]
11793 grid x $page.diffoldbut $page.diffold -sticky w
11794
11795 label $page.diffoldbg -padx 40 -relief sunk -background [lindex $diffbgcolors 0]
11796 ttk::button $page.diffoldbgbut -text [mc "Diff: old lines bg"] \
11797 -command [list choosecolor diffbgcolors 0 $page [mc "diff old lines bg"]]
11798 grid x $page.diffoldbgbut $page.diffoldbg -sticky w
11799
11800 label $page.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
11801 ttk::button $page.diffnewbut -text [mc "Diff: new lines"] \
11802 -command [list choosecolor diffcolors 1 $page [mc "diff new lines"]]
11803 grid x $page.diffnewbut $page.diffnew -sticky w
11804
11805 label $page.diffnewbg -padx 40 -relief sunk -background [lindex $diffbgcolors 1]
11806 ttk::button $page.diffnewbgbut -text [mc "Diff: new lines bg"] \
11807 -command [list choosecolor diffbgcolors 1 $page [mc "diff new lines bg"]]
11808 grid x $page.diffnewbgbut $page.diffnewbg -sticky w
11809
11810 label $page.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
11811 ttk::button $page.hunksepbut -text [mc "Diff: hunk header"] \
11812 -command [list choosecolor diffcolors 2 $page [mc "diff hunk header"]]
11813 grid x $page.hunksepbut $page.hunksep -sticky w
11814
11815 label $page.markbgsep -padx 40 -relief sunk -background $markbgcolor
11816 ttk::button $page.markbgbut -text [mc "Marked line bg"] \
11817 -command [list choosecolor markbgcolor {} $page [mc "marked line background"]]
11818 grid x $page.markbgbut $page.markbgsep -sticky w
11819
11820 label $page.selbgsep -padx 40 -relief sunk -background $selectbgcolor
11821 ttk::button $page.selbgbut -text [mc "Select bg"] \
11822 -command [list choosecolor selectbgcolor {} $page [mc "background"]]
11823 grid x $page.selbgbut $page.selbgsep -sticky w
11824
11825 grid columnconfigure $page 2 -weight 1
11826
11827 return $page
11828}
11829
11830proc prefspage_set_colorswatches {page} {
11831 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
11832 global diffbgcolors
11833
11834 $page.bg configure -background $bgcolor
11835 $page.fg configure -background $fgcolor
11836 $page.diffold configure -background [lindex $diffcolors 0]
11837 $page.diffoldbg configure -background [lindex $diffbgcolors 0]
11838 $page.diffnew configure -background [lindex $diffcolors 1]
11839 $page.diffnewbg configure -background [lindex $diffbgcolors 1]
11840 $page.hunksep configure -background [lindex $diffcolors 2]
11841 $page.markbgsep configure -background $markbgcolor
11842 $page.selbgsep configure -background $selectbgcolor
11843}
11844
11845proc prefspage_fonts {notebook} {
11846 set page [create_prefs_page $notebook.fonts]
11847 ttk::label $page.cfont -text [mc "Fonts: press to choose"] -font mainfontbold
11848 grid $page.cfont - -sticky w -pady 10
11849 mkfontdisp mainfont $page [mc "Main font"]
11850 mkfontdisp textfont $page [mc "Diff display font"]
11851 mkfontdisp uifont $page [mc "User interface font"]
11852 grid columnconfigure $page 2 -weight 1
11853 return $page
11854}
11855
11856proc doprefs {} {
11857 global oldprefs prefstop
11858 global {*}$::config_variables
11859
11860 set top .gitkprefs
11861 set prefstop $top
11862 if {[winfo exists $top]} {
11863 raise $top
11864 return
11865 }
11866 foreach v $::config_variables {
11867 set oldprefs($v) [set $v]
11868 }
11869 ttk_toplevel $top
11870 wm title $top [mc "Gitk preferences"]
11871 make_transient $top .
11872
11873 set notebook [ttk::notebook $top.notebook]
11874
11875 lappend pages [prefspage_general $notebook] [mc "General"]
11876 lappend pages [prefspage_colors $notebook] [mc "Colors"]
11877 lappend pages [prefspage_fonts $notebook] [mc "Fonts"]
11878 set col 0
11879 foreach {page title} $pages {
11880 $notebook add $page -text $title
11881 }
11882
11883 grid columnconfigure $notebook 0 -weight 1
11884 grid rowconfigure $notebook 1 -weight 1
11885 raise [lindex $pages 0]
11886
11887 grid $notebook -sticky news -padx 3 -pady 3
11888 grid rowconfigure $top 0 -weight 1
11889 grid columnconfigure $top 0 -weight 1
11890
11891 ttk::frame $top.buts
11892 ttk::button $top.buts.ok -text [mc "OK"] -command prefsok -default active
11893 ttk::button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
11894 bind $top <Key-Return> prefsok
11895 bind $top <Key-Escape> prefscan
11896 grid $top.buts.ok $top.buts.can -padx 20
11897 grid $top.buts -sticky w -pady 10
11898 bind $top <Visibility> [list focus $top.buts.ok]
11899
11900 # let geometry manager determine run, set minimum size
11901 update idletasks
11902 wm minsize $top [winfo reqwidth $top] [winfo reqheight $top]
11903}
11904
11905proc choose_extdiff {} {
11906 global extdifftool
11907
11908 set prog [tk_getOpenFile -title [mc "External diff tool"] -multiple false]
11909 if {$prog ne {}} {
11910 set extdifftool $prog
11911 }
11912}
11913
11914proc run_themeloader {f} {
11915 if {![info exists ::_themefiles_seen]} {
11916 set ::_themefiles_seen [dict create]
11917 }
11918
11919 set fn [file normalize $f]
11920 if {![dict exists $::_themefiles_seen $fn]} {
11921 if {[catch {source $fn} err]} {
11922 error_popup "could not interpret: $fn\n$err"
11923 dict set ::_themefiles_seen $fn 0
11924 } else {
11925 dict set ::_themefiles_seen $fn 1
11926 }
11927 }
11928 return [dict get $::_themefiles_seen $fn]
11929}
11930
11931proc updatetheme {prefspage {dotheme 1}} {
11932 global theme
11933 global themeloader
11934 if {$themeloader ne {}} {
11935 if {![run_themeloader $themeloader]} {
11936 set themeloader {}
11937 return
11938 } else {
11939 $prefspage.theme configure -values \
11940 [lsort [ttk::style theme names]]
11941 }
11942 }
11943 if {$dotheme} {
11944 ttk::style theme use $theme
11945 set_gui_colors
11946 prefspage_set_colorswatches $prefspage
11947 }
11948}
11949
11950proc choose_themeloader {prefspage} {
11951 global themeloader
11952 set tfile [tk_getOpenFile -title [mc "Gitk: select theme definition"] -multiple false]
11953 if {$tfile ne {}} {
11954 set themeloader $tfile
11955 updatetheme $prefspage 0
11956 }
11957}
11958
11959proc choosecolor {v vi prefspage x} {
11960 global $v
11961
11962 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
11963 -title [mc "Gitk: choose color for %s" $x]]
11964 if {$c eq {}} return
11965 lset $v $vi $c
11966 set_gui_colors
11967 prefspage_set_colorswatches $prefspage
11968}
11969
11970proc setselbg {c} {
11971 global bglist cflist
11972 foreach w $bglist {
11973 if {[winfo exists $w]} {
11974 $w configure -selectbackground $c
11975 }
11976 }
11977 $cflist tag configure highlight \
11978 -background [$cflist cget -selectbackground]
11979 allcanvs itemconf secsel -fill $c
11980}
11981
11982proc setbg {c} {
11983 global bglist
11984
11985 foreach w $bglist {
11986 if {[winfo exists $w]} {
11987 $w conf -background $c
11988 }
11989 }
11990}
11991
11992proc setfg {c} {
11993 global fglist canv
11994
11995 foreach w $fglist {
11996 if {[winfo exists $w]} {
11997 $w conf -foreground $c
11998 }
11999 }
12000 allcanvs itemconf text -fill $c
12001 $canv itemconf circle -outline $c
12002 $canv itemconf markid -outline $c
12003}
12004
12005proc set_gui_colors {} {
12006 global bgcolor fgcolor ctext diffcolors selectbgcolor markbgcolor
12007 global diffbgcolors
12008
12009 setbg $bgcolor
12010 setfg $fgcolor
12011 $ctext tag conf d0 -foreground [lindex $diffcolors 0]
12012 $ctext tag conf d0 -background [lindex $diffbgcolors 0]
12013 $ctext tag conf dresult -foreground [lindex $diffcolors 1]
12014 $ctext tag conf dresult -background [lindex $diffbgcolors 1]
12015 $ctext tag conf hunksep -foreground [lindex $diffcolors 2]
12016 $ctext tag conf omark -background $markbgcolor
12017 setselbg $selectbgcolor
12018}
12019
12020proc prefscan {} {
12021 global oldprefs prefstop
12022 global {*}$::config_variables
12023
12024 foreach v $::config_variables {
12025 set $v $oldprefs($v)
12026 }
12027 catch {destroy $prefstop}
12028 unset prefstop
12029 fontcan
12030 setttkstyle
12031 set_gui_colors
12032}
12033
12034proc prefsok {} {
12035 global oldprefs prefstop fontpref treediffs
12036 global {*}$::config_variables
12037 global ctext
12038
12039 catch {destroy $prefstop}
12040 unset prefstop
12041 fontcan
12042 set fontchanged 0
12043 if {$mainfont ne $fontpref(mainfont)} {
12044 set mainfont $fontpref(mainfont)
12045 parsefont mainfont $mainfont
12046 eval font configure mainfont [fontflags mainfont]
12047 eval font configure mainfontbold [fontflags mainfont 1]
12048 setcoords
12049 set fontchanged 1
12050 }
12051 if {$textfont ne $fontpref(textfont)} {
12052 set textfont $fontpref(textfont)
12053 parsefont textfont $textfont
12054 eval font configure textfont [fontflags textfont]
12055 eval font configure textfontbold [fontflags textfont 1]
12056 }
12057 if {$uifont ne $fontpref(uifont)} {
12058 set uifont $fontpref(uifont)
12059 parsefont uifont $uifont
12060 eval font configure uifont [fontflags uifont]
12061 }
12062 settabs
12063 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
12064 if {$showlocalchanges} {
12065 doshowlocalchanges
12066 } else {
12067 dohidelocalchanges
12068 }
12069 }
12070 if {$limitdiffs != $oldprefs(limitdiffs) ||
12071 ($perfile_attrs && !$oldprefs(perfile_attrs))} {
12072 # treediffs elements are limited by path;
12073 # won't have encodings cached if perfile_attrs was just turned on
12074 unset -nocomplain treediffs
12075 }
12076 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
12077 || $maxgraphpct != $oldprefs(maxgraphpct)} {
12078 redisplay
12079 } elseif {$showneartags != $oldprefs(showneartags) ||
12080 $limitdiffs != $oldprefs(limitdiffs)} {
12081 reselectline
12082 }
12083 if {$hideremotes != $oldprefs(hideremotes) || $refstohide != $oldprefs(refstohide)} {
12084 rereadrefs
12085 }
12086 if {$wrapcomment != $oldprefs(wrapcomment)} {
12087 $ctext tag conf comment -wrap $wrapcomment
12088 }
12089 if {$wrapdefault != $oldprefs(wrapdefault)} {
12090 $ctext configure -wrap $wrapdefault
12091 }
12092}
12093
12094proc formatdate {d} {
12095 global datetimeformat
12096 if {$d ne {}} {
12097 # If $datetimeformat includes a timezone, display in the
12098 # timezone of the argument. Otherwise, display in local time.
12099 if {[string match {*%[zZ]*} $datetimeformat]} {
12100 if {[catch {set d [clock format [lindex $d 0] -timezone [lindex $d 1] -format $datetimeformat]}]} {
12101 # Tcl < 8.5 does not support -timezone. Emulate it by
12102 # setting TZ (e.g. TZ=<-0430>+04:30).
12103 global env
12104 if {[info exists env(TZ)]} {
12105 set savedTZ $env(TZ)
12106 }
12107 set zone [lindex $d 1]
12108 set sign [string map {+ - - +} [string index $zone 0]]
12109 set env(TZ) <$zone>$sign[string range $zone 1 2]:[string range $zone 3 4]
12110 set d [clock format [lindex $d 0] -format $datetimeformat]
12111 if {[info exists savedTZ]} {
12112 set env(TZ) $savedTZ
12113 } else {
12114 unset env(TZ)
12115 }
12116 }
12117 } else {
12118 set d [clock format [lindex $d 0] -format $datetimeformat]
12119 }
12120 }
12121 return $d
12122}
12123
12124# This list of encoding names and aliases is distilled from
12125# https://www.iana.org/assignments/character-sets.
12126# Not all of them are supported by Tcl.
12127set encoding_aliases {
12128 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
12129 ISO646-US US-ASCII us IBM367 cp367 csASCII }
12130 { ISO-10646-UTF-1 csISO10646UTF1 }
12131 { ISO_646.basic:1983 ref csISO646basic1983 }
12132 { INVARIANT csINVARIANT }
12133 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
12134 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
12135 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
12136 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
12137 { NATS-DANO iso-ir-9-1 csNATSDANO }
12138 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
12139 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
12140 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
12141 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
12142 { ISO-2022-KR csISO2022KR }
12143 { EUC-KR csEUCKR }
12144 { ISO-2022-JP csISO2022JP }
12145 { ISO-2022-JP-2 csISO2022JP2 }
12146 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
12147 csISO13JISC6220jp }
12148 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
12149 { IT iso-ir-15 ISO646-IT csISO15Italian }
12150 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
12151 { ES iso-ir-17 ISO646-ES csISO17Spanish }
12152 { greek7-old iso-ir-18 csISO18Greek7Old }
12153 { latin-greek iso-ir-19 csISO19LatinGreek }
12154 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
12155 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
12156 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
12157 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
12158 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
12159 { BS_viewdata iso-ir-47 csISO47BSViewdata }
12160 { INIS iso-ir-49 csISO49INIS }
12161 { INIS-8 iso-ir-50 csISO50INIS8 }
12162 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
12163 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
12164 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
12165 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
12166 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
12167 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
12168 csISO60Norwegian1 }
12169 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
12170 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
12171 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
12172 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
12173 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
12174 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
12175 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
12176 { greek7 iso-ir-88 csISO88Greek7 }
12177 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
12178 { iso-ir-90 csISO90 }
12179 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
12180 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
12181 csISO92JISC62991984b }
12182 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
12183 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
12184 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
12185 csISO95JIS62291984handadd }
12186 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
12187 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
12188 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
12189 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
12190 CP819 csISOLatin1 }
12191 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
12192 { T.61-7bit iso-ir-102 csISO102T617bit }
12193 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
12194 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
12195 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
12196 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
12197 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
12198 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
12199 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
12200 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
12201 arabic csISOLatinArabic }
12202 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
12203 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
12204 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
12205 greek greek8 csISOLatinGreek }
12206 { T.101-G2 iso-ir-128 csISO128T101G2 }
12207 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
12208 csISOLatinHebrew }
12209 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
12210 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
12211 { CSN_369103 iso-ir-139 csISO139CSN369103 }
12212 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
12213 { ISO_6937-2-add iso-ir-142 csISOTextComm }
12214 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
12215 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
12216 csISOLatinCyrillic }
12217 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
12218 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
12219 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
12220 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
12221 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
12222 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
12223 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
12224 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
12225 { ISO_10367-box iso-ir-155 csISO10367Box }
12226 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
12227 { latin-lap lap iso-ir-158 csISO158Lap }
12228 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
12229 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
12230 { us-dk csUSDK }
12231 { dk-us csDKUS }
12232 { JIS_X0201 X0201 csHalfWidthKatakana }
12233 { KSC5636 ISO646-KR csKSC5636 }
12234 { ISO-10646-UCS-2 csUnicode }
12235 { ISO-10646-UCS-4 csUCS4 }
12236 { DEC-MCS dec csDECMCS }
12237 { hp-roman8 roman8 r8 csHPRoman8 }
12238 { macintosh mac csMacintosh }
12239 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
12240 csIBM037 }
12241 { IBM038 EBCDIC-INT cp038 csIBM038 }
12242 { IBM273 CP273 csIBM273 }
12243 { IBM274 EBCDIC-BE CP274 csIBM274 }
12244 { IBM275 EBCDIC-BR cp275 csIBM275 }
12245 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
12246 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
12247 { IBM280 CP280 ebcdic-cp-it csIBM280 }
12248 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
12249 { IBM284 CP284 ebcdic-cp-es csIBM284 }
12250 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
12251 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
12252 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
12253 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
12254 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
12255 { IBM424 cp424 ebcdic-cp-he csIBM424 }
12256 { IBM437 cp437 437 csPC8CodePage437 }
12257 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
12258 { IBM775 cp775 csPC775Baltic }
12259 { IBM850 cp850 850 csPC850Multilingual }
12260 { IBM851 cp851 851 csIBM851 }
12261 { IBM852 cp852 852 csPCp852 }
12262 { IBM855 cp855 855 csIBM855 }
12263 { IBM857 cp857 857 csIBM857 }
12264 { IBM860 cp860 860 csIBM860 }
12265 { IBM861 cp861 861 cp-is csIBM861 }
12266 { IBM862 cp862 862 csPC862LatinHebrew }
12267 { IBM863 cp863 863 csIBM863 }
12268 { IBM864 cp864 csIBM864 }
12269 { IBM865 cp865 865 csIBM865 }
12270 { IBM866 cp866 866 csIBM866 }
12271 { IBM868 CP868 cp-ar csIBM868 }
12272 { IBM869 cp869 869 cp-gr csIBM869 }
12273 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
12274 { IBM871 CP871 ebcdic-cp-is csIBM871 }
12275 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
12276 { IBM891 cp891 csIBM891 }
12277 { IBM903 cp903 csIBM903 }
12278 { IBM904 cp904 904 csIBBM904 }
12279 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
12280 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
12281 { IBM1026 CP1026 csIBM1026 }
12282 { EBCDIC-AT-DE csIBMEBCDICATDE }
12283 { EBCDIC-AT-DE-A csEBCDICATDEA }
12284 { EBCDIC-CA-FR csEBCDICCAFR }
12285 { EBCDIC-DK-NO csEBCDICDKNO }
12286 { EBCDIC-DK-NO-A csEBCDICDKNOA }
12287 { EBCDIC-FI-SE csEBCDICFISE }
12288 { EBCDIC-FI-SE-A csEBCDICFISEA }
12289 { EBCDIC-FR csEBCDICFR }
12290 { EBCDIC-IT csEBCDICIT }
12291 { EBCDIC-PT csEBCDICPT }
12292 { EBCDIC-ES csEBCDICES }
12293 { EBCDIC-ES-A csEBCDICESA }
12294 { EBCDIC-ES-S csEBCDICESS }
12295 { EBCDIC-UK csEBCDICUK }
12296 { EBCDIC-US csEBCDICUS }
12297 { UNKNOWN-8BIT csUnknown8BiT }
12298 { MNEMONIC csMnemonic }
12299 { MNEM csMnem }
12300 { VISCII csVISCII }
12301 { VIQR csVIQR }
12302 { KOI8-R csKOI8R }
12303 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
12304 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
12305 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
12306 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
12307 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
12308 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
12309 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
12310 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
12311 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
12312 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
12313 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
12314 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
12315 { IBM1047 IBM-1047 }
12316 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
12317 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
12318 { UNICODE-1-1 csUnicode11 }
12319 { CESU-8 csCESU-8 }
12320 { BOCU-1 csBOCU-1 }
12321 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
12322 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
12323 l8 }
12324 { ISO-8859-15 ISO_8859-15 Latin-9 }
12325 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
12326 { GBK CP936 MS936 windows-936 }
12327 { JIS_Encoding csJISEncoding }
12328 { Shift_JIS MS_Kanji csShiftJIS ShiftJIS Shift-JIS }
12329 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
12330 EUC-JP }
12331 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
12332 { ISO-10646-UCS-Basic csUnicodeASCII }
12333 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
12334 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
12335 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
12336 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
12337 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
12338 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
12339 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
12340 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
12341 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
12342 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
12343 { Adobe-Standard-Encoding csAdobeStandardEncoding }
12344 { Ventura-US csVenturaUS }
12345 { Ventura-International csVenturaInternational }
12346 { PC8-Danish-Norwegian csPC8DanishNorwegian }
12347 { PC8-Turkish csPC8Turkish }
12348 { IBM-Symbols csIBMSymbols }
12349 { IBM-Thai csIBMThai }
12350 { HP-Legal csHPLegal }
12351 { HP-Pi-font csHPPiFont }
12352 { HP-Math8 csHPMath8 }
12353 { Adobe-Symbol-Encoding csHPPSMath }
12354 { HP-DeskTop csHPDesktop }
12355 { Ventura-Math csVenturaMath }
12356 { Microsoft-Publishing csMicrosoftPublishing }
12357 { Windows-31J csWindows31J }
12358 { GB2312 csGB2312 }
12359 { Big5 csBig5 }
12360}
12361
12362proc tcl_encoding {enc} {
12363 global encoding_aliases tcl_encoding_cache
12364 if {[info exists tcl_encoding_cache($enc)]} {
12365 return $tcl_encoding_cache($enc)
12366 }
12367 set names [encoding names]
12368 set lcnames [string tolower $names]
12369 set enc [string tolower $enc]
12370 set i [lsearch -exact $lcnames $enc]
12371 if {$i < 0} {
12372 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
12373 if {[regsub {^(iso|cp|ibm|jis)[-_]} $enc {\1} encx]} {
12374 set i [lsearch -exact $lcnames $encx]
12375 }
12376 }
12377 if {$i < 0} {
12378 foreach l $encoding_aliases {
12379 set ll [string tolower $l]
12380 if {[lsearch -exact $ll $enc] < 0} continue
12381 # look through the aliases for one that tcl knows about
12382 foreach e $ll {
12383 set i [lsearch -exact $lcnames $e]
12384 if {$i < 0} {
12385 if {[regsub {^(iso|cp|ibm|jis)[-_]} $e {\1} ex]} {
12386 set i [lsearch -exact $lcnames $ex]
12387 }
12388 }
12389 if {$i >= 0} break
12390 }
12391 break
12392 }
12393 }
12394 set tclenc {}
12395 if {$i >= 0} {
12396 set tclenc [lindex $names $i]
12397 }
12398 set tcl_encoding_cache($enc) $tclenc
12399 return $tclenc
12400}
12401
12402proc gitattr {path attr default} {
12403 global path_attr_cache
12404 if {[info exists path_attr_cache($attr,$path)]} {
12405 set r $path_attr_cache($attr,$path)
12406 } else {
12407 set r "unspecified"
12408 if {![catch {set line [safe_exec [list git check-attr $attr -- $path]]}]} {
12409 regexp "(.*): $attr: (.*)" $line m f r
12410 }
12411 set path_attr_cache($attr,$path) $r
12412 }
12413 if {$r eq "unspecified"} {
12414 return $default
12415 }
12416 return $r
12417}
12418
12419proc cache_gitattr {attr pathlist} {
12420 global path_attr_cache
12421 set newlist {}
12422 foreach path $pathlist {
12423 if {![info exists path_attr_cache($attr,$path)]} {
12424 lappend newlist $path
12425 }
12426 }
12427 set lim 1000
12428 if {[tk windowingsystem] == "win32"} {
12429 # windows has a 32k limit on the arguments to a command...
12430 set lim 30
12431 }
12432 while {$newlist ne {}} {
12433 set head [lrange $newlist 0 [expr {$lim - 1}]]
12434 set newlist [lrange $newlist $lim end]
12435 if {![catch {set rlist [safe_exec [concat git check-attr $attr -- $head]]}]} {
12436 foreach row [split $rlist "\n"] {
12437 if {[regexp "(.*): $attr: (.*)" $row m path value]} {
12438 if {[string index $path 0] eq "\""} {
12439 set path [convertfrom utf-8 [lindex $path 0]]
12440 }
12441 set path_attr_cache($attr,$path) $value
12442 }
12443 }
12444 }
12445 }
12446}
12447
12448proc get_path_encoding {path} {
12449 global gui_encoding perfile_attrs
12450 set tcl_enc $gui_encoding
12451 if {$path ne {} && $perfile_attrs} {
12452 set enc2 [tcl_encoding [gitattr $path encoding $tcl_enc]]
12453 if {$enc2 ne {}} {
12454 set tcl_enc $enc2
12455 }
12456 }
12457 return $tcl_enc
12458}
12459
12460proc is_other_ref_visible {ref} {
12461 global refstohide
12462
12463 if {$refstohide eq {}} {
12464 return 1
12465 }
12466
12467 foreach pat [split $refstohide " "] {
12468 if {$pat eq {}} continue
12469 if {[string match $pat $ref]} {
12470 return 0
12471 }
12472 }
12473
12474 return 1
12475}
12476
12477## For msgcat loading, first locate the installation location.
12478if { [info exists ::env(GITK_MSGSDIR)] } {
12479 ## Msgsdir was manually set in the environment.
12480 set gitk_msgsdir $::env(GITK_MSGSDIR)
12481} else {
12482 ## Let's guess the prefix from argv0.
12483 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
12484 set gitk_libdir [file join $gitk_prefix share gitk lib]
12485 set gitk_msgsdir [file join $gitk_libdir msgs]
12486}
12487
12488## Internationalization (i18n) through msgcat and gettext. See
12489## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
12490package require msgcat
12491namespace import ::msgcat::mc
12492## And eventually load the actual message catalog
12493::msgcat::mcload $gitk_msgsdir
12494
12495# on OSX bring the current Wish process window to front
12496if {[tk windowingsystem] eq "aqua"} {
12497 catch {
12498 safe_exec [list osascript -e [format {
12499 tell application "System Events"
12500 set frontmost of processes whose unix id is %d to true
12501 end tell
12502 } [pid] ]]
12503 }
12504}
12505
12506# Unset GIT_TRACE var if set
12507if { [info exists ::env(GIT_TRACE)] } {
12508 unset ::env(GIT_TRACE)
12509}
12510
12511# defaults...
12512set wrcomcmd "git diff-tree --stdin -p --pretty=email"
12513
12514set gitencoding {}
12515catch {
12516 set gitencoding [exec git config --get i18n.commitencoding]
12517}
12518catch {
12519 set gitencoding [exec git config --get i18n.logoutputencoding]
12520}
12521if {$gitencoding == ""} {
12522 set gitencoding "utf-8"
12523}
12524set tclencoding [tcl_encoding $gitencoding]
12525if {$tclencoding == {}} {
12526 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
12527}
12528
12529set gui_encoding [encoding system]
12530catch {
12531 set enc [exec git config --get gui.encoding]
12532 if {$enc ne {}} {
12533 set tclenc [tcl_encoding $enc]
12534 if {$tclenc ne {}} {
12535 set gui_encoding $tclenc
12536 } else {
12537 puts stderr "Warning: encoding $enc is not supported by Tcl/Tk"
12538 }
12539 }
12540}
12541
12542# Use object format as hash algorightm (either "sha1" or "sha256")
12543set hashalgorithm [exec git rev-parse --show-object-format]
12544if {$hashalgorithm eq "sha1"} {
12545 set hashlength 40
12546} elseif {$hashalgorithm eq "sha256"} {
12547 set hashlength 64
12548} else {
12549 puts stderr "Unknown hash algorithm: $hashalgorithm"
12550 exit 1
12551}
12552
12553set log_showroot true
12554catch {
12555 set log_showroot [exec git config --bool --get log.showroot]
12556}
12557
12558if {[tk windowingsystem] eq "aqua"} {
12559 set mainfont {{Lucida Grande} 9}
12560 set textfont {Monaco 9}
12561 set uifont {{Lucida Grande} 9 bold}
12562} elseif {![catch {::tk::pkgconfig get fontsystem} xft] && $xft eq "xft"} {
12563 # fontconfig!
12564 set mainfont {sans 9}
12565 set textfont {monospace 9}
12566 set uifont {sans 9 bold}
12567} else {
12568 set mainfont {Helvetica 9}
12569 set textfont {Courier 9}
12570 set uifont {Helvetica 9 bold}
12571}
12572set tabstop 8
12573set findmergefiles 0
12574set maxgraphpct 50
12575set maxwidth 16
12576set revlistorder 0
12577set fastdate 0
12578set uparrowlen 5
12579set downarrowlen 5
12580set mingaplen 100
12581set cmitmode "patch"
12582set wrapcomment "none"
12583set wrapdefault "none"
12584set showneartags 1
12585set hideremotes 0
12586set refstohide ""
12587set sortrefsbytype 1
12588set maxrefs 20
12589set visiblerefs {"master"}
12590set maxlinelen 200
12591set showlocalchanges 1
12592set limitdiffs 1
12593set kscroll 3
12594set datetimeformat "%Y-%m-%d %H:%M:%S"
12595set autocopy 0
12596set autoselect 1
12597set autosellen $hashlength
12598set perfile_attrs 0
12599
12600if {[tk windowingsystem] eq "aqua"} {
12601 set extdifftool "opendiff"
12602} else {
12603 set extdifftool "meld"
12604}
12605
12606set colors {"#00ff00" red blue magenta darkgrey brown orange}
12607if {[tk windowingsystem] eq "win32"} {
12608 set bgcolor SystemWindow
12609 set fgcolor SystemWindowText
12610 set selectbgcolor SystemHighlight
12611 set web_browser "cmd /c start"
12612} else {
12613 set bgcolor white
12614 set fgcolor black
12615 set selectbgcolor gray85
12616 if {[tk windowingsystem] eq "aqua"} {
12617 set web_browser "open"
12618 } else {
12619 set web_browser "xdg-open"
12620 }
12621}
12622set diffcolors {"#c30000" "#009800" blue}
12623set diffbgcolors {"#fff3f3" "#f0fff0"}
12624set diffcontext 3
12625set mergecolors {red blue "#00ff00" purple brown "#009090" magenta "#808000" "#009000" "#ff0080" cyan "#b07070" "#70b0f0" "#70f0b0" "#f0b070" "#ff70b0"}
12626set ignorespace 0
12627set worddiff ""
12628set markbgcolor "#e0e0ff"
12629
12630set headbgcolor "#00ff00"
12631set headfgcolor black
12632set headoutlinecolor black
12633set remotebgcolor #ffddaa
12634set tagbgcolor yellow
12635set tagfgcolor black
12636set tagoutlinecolor black
12637set reflinecolor black
12638set filesepbgcolor #aaaaaa
12639set filesepfgcolor black
12640set linehoverbgcolor #ffff80
12641set linehoverfgcolor black
12642set linehoveroutlinecolor black
12643set mainheadcirclecolor yellow
12644set workingfilescirclecolor red
12645set indexcirclecolor "#00ff00"
12646set circlecolors {white blue gray blue blue}
12647set linkfgcolor blue
12648set circleoutlinecolor $fgcolor
12649set foundbgcolor yellow
12650set currentsearchhitbgcolor orange
12651
12652set theme [ttk::style theme use]
12653set themeloader {}
12654set uicolor {}
12655set uifgcolor {}
12656set uifgdisabledcolor {}
12657
12658# button for popping up context menus
12659if {[tk windowingsystem] eq "aqua" && [package vcompare $::tcl_version 8.7] < 0} {
12660 set ctxbut <Button-2>
12661} else {
12662 set ctxbut <Button-3>
12663}
12664
12665catch {
12666 # follow the XDG base directory specification by default. See
12667 # https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html
12668 if {[info exists env(XDG_CONFIG_HOME)] && $env(XDG_CONFIG_HOME) ne ""} {
12669 # XDG_CONFIG_HOME environment variable is set
12670 set config_file [file join $env(XDG_CONFIG_HOME) git gitk]
12671 set config_file_tmp [file join $env(XDG_CONFIG_HOME) git gitk-tmp]
12672 } else {
12673 # default XDG_CONFIG_HOME
12674 set config_file "$env(HOME)/.config/git/gitk"
12675 set config_file_tmp "$env(HOME)/.config/git/gitk-tmp"
12676 }
12677 if {![file exists $config_file]} {
12678 # for backward compatibility use the old config file if it exists
12679 if {[file exists "$env(HOME)/.gitk"]} {
12680 set config_file "$env(HOME)/.gitk"
12681 set config_file_tmp "$env(HOME)/.gitk-tmp"
12682 } elseif {![file exists [file dirname $config_file]]} {
12683 file mkdir [file dirname $config_file]
12684 }
12685 }
12686 source $config_file
12687}
12688config_check_tmp_exists 50
12689
12690set config_variables {
12691 autocopy
12692 autoselect
12693 autosellen
12694 bgcolor
12695 circlecolors
12696 circleoutlinecolor
12697 cmitmode
12698 colors
12699 currentsearchhitbgcolor
12700 datetimeformat
12701 diffbgcolors
12702 diffcolors
12703 diffcontext
12704 extdifftool
12705 fgcolor
12706 filesepbgcolor
12707 filesepfgcolor
12708 findmergefiles
12709 foundbgcolor
12710 headbgcolor
12711 headfgcolor
12712 headoutlinecolor
12713 hideremotes
12714 indexcirclecolor
12715 kscroll
12716 limitdiffs
12717 linehoverbgcolor
12718 linehoverfgcolor
12719 linehoveroutlinecolor
12720 linkfgcolor
12721 mainfont
12722 mainheadcirclecolor
12723 markbgcolor
12724 maxgraphpct
12725 maxrefs
12726 maxwidth
12727 mergecolors
12728 perfile_attrs
12729 reflinecolor
12730 refstohide
12731 remotebgcolor
12732 selectbgcolor
12733 showlocalchanges
12734 showneartags
12735 sortrefsbytype
12736 tabstop
12737 tagbgcolor
12738 tagfgcolor
12739 tagoutlinecolor
12740 textfont
12741 theme
12742 themeloader
12743 uicolor
12744 uifgcolor
12745 uifgdisabledcolor
12746 uifont
12747 visiblerefs
12748 web_browser
12749 workingfilescirclecolor
12750 wrapcomment
12751 wrapdefault
12752}
12753
12754foreach var $config_variables {
12755 config_init_trace $var
12756 trace add variable $var write config_variable_change_cb
12757}
12758
12759parsefont mainfont $mainfont
12760eval font create mainfont [fontflags mainfont]
12761eval font create mainfontbold [fontflags mainfont 1]
12762
12763parsefont textfont $textfont
12764eval font create textfont [fontflags textfont]
12765eval font create textfontbold [fontflags textfont 1]
12766
12767parsefont uifont $uifont
12768eval font create uifont [fontflags uifont]
12769
12770setoptions
12771
12772# check that we can find a .git directory somewhere...
12773if {[catch {set gitdir [exec git rev-parse --git-dir]}]} {
12774 show_error {} . [mc "Cannot find a git repository here."]
12775 exit 1
12776}
12777
12778set selecthead {}
12779set selectheadid {}
12780
12781set revtreeargs {}
12782set cmdline_files {}
12783set i 0
12784set revtreeargscmd {}
12785foreach arg $argv {
12786 switch -glob -- $arg {
12787 "" { }
12788 "--" {
12789 set cmdline_files [lrange $argv [expr {$i + 1}] end]
12790 break
12791 }
12792 "--select-commit=*" {
12793 set selecthead [string range $arg 16 end]
12794 }
12795 "--argscmd=*" {
12796 set revtreeargscmd [string range $arg 10 end]
12797 }
12798 default {
12799 lappend revtreeargs $arg
12800 }
12801 }
12802 incr i
12803}
12804
12805if {$selecthead eq "HEAD"} {
12806 set selecthead {}
12807}
12808
12809if {$i >= [llength $argv] && $revtreeargs ne {}} {
12810 # no -- on command line, but some arguments (other than --argscmd)
12811 if {[catch {
12812 set f [safe_exec [concat git rev-parse --no-revs --no-flags $revtreeargs]]
12813 set cmdline_files [split $f "\n"]
12814 set n [llength $cmdline_files]
12815 set revtreeargs [lrange $revtreeargs 0 end-$n]
12816 # Unfortunately git rev-parse doesn't produce an error when
12817 # something is both a revision and a filename. To be consistent
12818 # with git log and git rev-list, check revtreeargs for filenames.
12819 foreach arg $revtreeargs {
12820 if {[file exists $arg]} {
12821 show_error {} . [mc "Ambiguous argument '%s': both revision\
12822 and filename" $arg]
12823 exit 1
12824 }
12825 }
12826 } err]} {
12827 # unfortunately we get both stdout and stderr in $err,
12828 # so look for "fatal:".
12829 set i [string first "fatal:" $err]
12830 if {$i > 0} {
12831 set err [string range $err [expr {$i + 6}] end]
12832 }
12833 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
12834 exit 1
12835 }
12836}
12837
12838set nullid "0000000000000000000000000000000000000000"
12839set nullid2 "0000000000000000000000000000000000000001"
12840set nullfile "/dev/null"
12841
12842if {[file exists $themeloader]} {
12843 if {![run_themeloader $themeloader]} {
12844 puts stderr "Could not interpret themeloader: $themeloader"
12845 exit 1
12846 }
12847}
12848
12849set appname "gitk"
12850
12851set runq {}
12852set history {}
12853set historyindex 0
12854set fh_serial 0
12855set nhl_names {}
12856set highlight_paths {}
12857set findpattern {}
12858set searchdirn -forwards
12859set boldids {}
12860set boldnameids {}
12861set diffelide {0 0}
12862set markingmatches 0
12863set linkentercount 0
12864set need_redisplay 0
12865set nrows_drawn 0
12866set firsttabstop 0
12867
12868set nextviewnum 1
12869set curview 0
12870set selectedview 0
12871set selectedhlview [mc "None"]
12872set highlight_related [mc "None"]
12873set highlight_files {}
12874set viewfiles(0) {}
12875set viewperm(0) 0
12876set viewchanged(0) 0
12877set viewargs(0) {}
12878set viewargscmd(0) {}
12879
12880set selectedline {}
12881set numcommits 0
12882set loginstance 0
12883set cmdlineok 0
12884set stopped 0
12885set stuffsaved 0
12886set patchnum 0
12887set lserial 0
12888set hasworktree [hasworktree]
12889set cdup {}
12890if {[expr {[exec git rev-parse --is-inside-work-tree] == "true"}]} {
12891 set cdup [exec git rev-parse --show-cdup]
12892}
12893set worktree [gitworktree]
12894setcoords
12895makewindow
12896if {$::tcl_platform(platform) eq {windows} && [file exists $gitk_prefix/etc/git.ico]} {
12897 wm iconbitmap . -default $gitk_prefix/etc/git.ico
12898} else {
12899 catch {
12900 image create photo gitlogo -width 16 -height 16
12901
12902 image create photo gitlogominus -width 4 -height 2
12903 gitlogominus put #C00000 -to 0 0 4 2
12904 gitlogo copy gitlogominus -to 1 5
12905 gitlogo copy gitlogominus -to 6 5
12906 gitlogo copy gitlogominus -to 11 5
12907 image delete gitlogominus
12908
12909 image create photo gitlogoplus -width 4 -height 4
12910 gitlogoplus put #008000 -to 1 0 3 4
12911 gitlogoplus put #008000 -to 0 1 4 3
12912 gitlogo copy gitlogoplus -to 1 9
12913 gitlogo copy gitlogoplus -to 6 9
12914 gitlogo copy gitlogoplus -to 11 9
12915 image delete gitlogoplus
12916
12917 image create photo gitlogo32 -width 32 -height 32
12918 gitlogo32 copy gitlogo -zoom 2 2
12919
12920 wm iconphoto . -default gitlogo gitlogo32
12921 }
12922}
12923# wait for the window to become visible
12924if {![winfo viewable .]} {tkwait visibility .}
12925set_window_title
12926update
12927readrefs
12928
12929if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
12930 # create a view for the files/dirs specified on the command line
12931 set curview 1
12932 set selectedview 1
12933 set nextviewnum 2
12934 set viewname(1) [mc "Command line"]
12935 set viewfiles(1) $cmdline_files
12936 set viewargs(1) $revtreeargs
12937 set viewargscmd(1) $revtreeargscmd
12938 set viewperm(1) 0
12939 set viewchanged(1) 0
12940 set vdatemode(1) 0
12941 addviewmenu 1
12942 .bar.view entryconf [mca "&Edit view..."] -state normal
12943 .bar.view entryconf [mca "&Delete view"] -state normal
12944}
12945
12946if {[info exists permviews]} {
12947 foreach v $permviews {
12948 set n $nextviewnum
12949 incr nextviewnum
12950 set viewname($n) [lindex $v 0]
12951 set viewfiles($n) [lindex $v 1]
12952 set viewargs($n) [lindex $v 2]
12953 set viewargscmd($n) [lindex $v 3]
12954 set viewperm($n) 1
12955 set viewchanged($n) 0
12956 addviewmenu $n
12957 }
12958}
12959
12960if {[tk windowingsystem] eq "win32"} {
12961 focus -force .
12962}
12963
12964setttkstyle
12965set_gui_colors
12966
12967getcommits {}
12968
12969# Local variables:
12970# mode: tcl
12971# indent-tabs-mode: t
12972# tab-width: 8
12973# End: