- if {[eof $fd]} {
- close $fd
- set diff_active 0
- unlock_index
- set ui_status_value {Ready.}
-
- if {[$ui_diff index end] eq {2.0}} {
- handle_empty_diff
- }
- }
-}
-
-proc apply_hunk {x y} {
- global current_diff_path current_diff_header current_diff_side
- global ui_diff ui_index file_states
-
- if {$current_diff_path eq {} || $current_diff_header eq {}} return
- if {![lock_index apply_hunk]} return
-
- set apply_cmd {git apply --cached --whitespace=nowarn}
- set mi [lindex $file_states($current_diff_path) 0]
- if {$current_diff_side eq $ui_index} {
- set mode unstage
- lappend apply_cmd --reverse
- if {[string index $mi 0] ne {M}} {
- unlock_index
- return
- }
- } else {
- set mode stage
- if {[string index $mi 1] ne {M}} {
- unlock_index
- return
- }
- }
-
- set s_lno [lindex [split [$ui_diff index @$x,$y] .] 0]
- set s_lno [$ui_diff search -backwards -regexp ^@@ $s_lno.0 0.0]
- if {$s_lno eq {}} {
- unlock_index
- return
- }
-
- set e_lno [$ui_diff search -forwards -regexp ^@@ "$s_lno + 1 lines" end]
- if {$e_lno eq {}} {
- set e_lno end
- }
-
- if {[catch {
- set p [open "| $apply_cmd" w]
- fconfigure $p -translation binary -encoding binary
- puts -nonewline $p $current_diff_header
- puts -nonewline $p [$ui_diff get $s_lno $e_lno]
- close $p} err]} {
- error_popup "Failed to $mode selected hunk.\n\n$err"
- unlock_index
- return
- }
-
- $ui_diff conf -state normal
- $ui_diff delete $s_lno $e_lno
- $ui_diff conf -state disabled
-
- if {[$ui_diff get 1.0 end] eq "\n"} {
- set o _
- } else {
- set o ?
- }
-
- if {$current_diff_side eq $ui_index} {
- set mi ${o}M
- } elseif {[string index $mi 0] eq {_}} {
- set mi M$o
- } else {
- set mi ?$o
- }
- unlock_index
- display_file $current_diff_path $mi
- if {$o eq {_}} {
- clear_diff
- }
-}
-
-######################################################################
-##
-## commit
-
-proc load_last_commit {} {
- global HEAD PARENT MERGE_HEAD commit_type ui_comm
- global repo_config
-
- if {[llength $PARENT] == 0} {
- error_popup {There is nothing to amend.
-
-You are about to create the initial commit.
-There is no commit before this to amend.
-}
- return
- }
-
- repository_state curType curHEAD curMERGE_HEAD
- if {$curType eq {merge}} {
- error_popup {Cannot amend while merging.
-
-You are currently in the middle of a merge that
-has not been fully completed. You cannot amend
-the prior commit unless you first abort the
-current merge activity.
-}
- return
- }
-
- set msg {}
- set parents [list]
- if {[catch {
- set fd [open "| git cat-file commit $curHEAD" r]
- fconfigure $fd -encoding binary -translation lf
- if {[catch {set enc $repo_config(i18n.commitencoding)}]} {
- set enc utf-8
- }
- while {[gets $fd line] > 0} {
- if {[string match {parent *} $line]} {
- lappend parents [string range $line 7 end]
- } elseif {[string match {encoding *} $line]} {
- set enc [string tolower [string range $line 9 end]]
- }
- }
- fconfigure $fd -encoding $enc
- set msg [string trim [read $fd]]
- close $fd
- } err]} {
- error_popup "Error loading commit data for amend:\n\n$err"
- return
- }
-
- set HEAD $curHEAD
- set PARENT $parents
- set MERGE_HEAD [list]
- switch -- [llength $parents] {
- 0 {set commit_type amend-initial}
- 1 {set commit_type amend}
- default {set commit_type amend-merge}
- }
-
- $ui_comm delete 0.0 end
- $ui_comm insert end $msg
- $ui_comm edit reset
- $ui_comm edit modified false
- rescan {set ui_status_value {Ready.}}
-}
-
-proc create_new_commit {} {
- global commit_type ui_comm
-
- set commit_type normal
- $ui_comm delete 0.0 end
- $ui_comm edit reset
- $ui_comm edit modified false
- rescan {set ui_status_value {Ready.}}
-}
-
-set GIT_COMMITTER_IDENT {}
-
-proc committer_ident {} {
- global GIT_COMMITTER_IDENT
-
- if {$GIT_COMMITTER_IDENT eq {}} {
- if {[catch {set me [git var GIT_COMMITTER_IDENT]} err]} {
- error_popup "Unable to obtain your identity:\n\n$err"
- return {}
- }
- if {![regexp {^(.*) [0-9]+ [-+0-9]+$} \
- $me me GIT_COMMITTER_IDENT]} {
- error_popup "Invalid GIT_COMMITTER_IDENT:\n\n$me"
- return {}
- }
- }
-
- return $GIT_COMMITTER_IDENT
-}
-
-proc commit_tree {} {
- global HEAD commit_type file_states ui_comm repo_config
- global ui_status_value pch_error
-
- if {[committer_ident] eq {}} return
- if {![lock_index update]} return
-
- # -- Our in memory state should match the repository.
- #
- repository_state curType curHEAD curMERGE_HEAD
- if {[string match amend* $commit_type]
- && $curType eq {normal}
- && $curHEAD eq $HEAD} {
- } elseif {$commit_type ne $curType || $HEAD ne $curHEAD} {
- info_popup {Last scanned state does not match repository state.
-
-Another Git program has modified this repository
-since the last scan. A rescan must be performed
-before another commit can be created.
-
-The rescan will be automatically started now.
-}
- unlock_index
- rescan {set ui_status_value {Ready.}}
- return
- }
-
- # -- At least one file should differ in the index.
- #
- set files_ready 0
- foreach path [array names file_states] {
- switch -glob -- [lindex $file_states($path) 0] {
- _? {continue}
- A? -
- D? -
- M? {set files_ready 1}
- U? {
- error_popup "Unmerged files cannot be committed.
-
-File [short_path $path] has merge conflicts.
-You must resolve them and add the file before committing.
-"
- unlock_index
- return
- }
- default {
- error_popup "Unknown file state [lindex $s 0] detected.
-
-File [short_path $path] cannot be committed by this program.
-"
- }
- }
- }
- if {!$files_ready} {
- info_popup {No changes to commit.
-
-You must add at least 1 file before you can commit.
-}
- unlock_index
- return
- }
-
- # -- A message is required.
- #
- set msg [string trim [$ui_comm get 1.0 end]]
- regsub -all -line {[ \t\r]+$} $msg {} msg
- if {$msg eq {}} {
- error_popup {Please supply a commit message.
-
-A good commit message has the following format:
-
-- First line: Describe in one sentance what you did.
-- Second line: Blank
-- Remaining lines: Describe why this change is good.
-}
- unlock_index
- return
- }
-
- # -- Run the pre-commit hook.
- #
- set pchook [gitdir hooks pre-commit]
-
- # On Cygwin [file executable] might lie so we need to ask
- # the shell if the hook is executable. Yes that's annoying.
- #
- if {[is_Cygwin] && [file isfile $pchook]} {
- set pchook [list sh -c [concat \
- "if test -x \"$pchook\";" \
- "then exec \"$pchook\" 2>&1;" \
- "fi"]]
- } elseif {[file executable $pchook]} {
- set pchook [list $pchook |& cat]
- } else {
- commit_writetree $curHEAD $msg
- return
- }
-
- set ui_status_value {Calling pre-commit hook...}
- set pch_error {}
- set fd_ph [open "| $pchook" r]
- fconfigure $fd_ph -blocking 0 -translation binary
- fileevent $fd_ph readable \
- [list commit_prehook_wait $fd_ph $curHEAD $msg]
-}
-
-proc commit_prehook_wait {fd_ph curHEAD msg} {
- global pch_error ui_status_value
-
- append pch_error [read $fd_ph]
- fconfigure $fd_ph -blocking 1
- if {[eof $fd_ph]} {
- if {[catch {close $fd_ph}]} {
- set ui_status_value {Commit declined by pre-commit hook.}
- hook_failed_popup pre-commit $pch_error
- unlock_index
- } else {
- commit_writetree $curHEAD $msg
- }
- set pch_error {}
- return
- }
- fconfigure $fd_ph -blocking 0
-}
-
-proc commit_writetree {curHEAD msg} {
- global ui_status_value
-
- set ui_status_value {Committing changes...}
- set fd_wt [open "| git write-tree" r]
- fileevent $fd_wt readable \
- [list commit_committree $fd_wt $curHEAD $msg]
-}
-
-proc commit_committree {fd_wt curHEAD msg} {
- global HEAD PARENT MERGE_HEAD commit_type
- global all_heads current_branch
- global ui_status_value ui_comm selected_commit_type
- global file_states selected_paths rescan_active
- global repo_config
-
- gets $fd_wt tree_id
- if {$tree_id eq {} || [catch {close $fd_wt} err]} {
- error_popup "write-tree failed:\n\n$err"
- set ui_status_value {Commit failed.}
- unlock_index
- return
- }
-
- # -- Build the message.
- #
- set msg_p [gitdir COMMIT_EDITMSG]
- set msg_wt [open $msg_p w]
- if {[catch {set enc $repo_config(i18n.commitencoding)}]} {
- set enc utf-8
- }
- fconfigure $msg_wt -encoding $enc -translation binary
- puts -nonewline $msg_wt $msg
- close $msg_wt
-
- # -- Create the commit.
- #
- set cmd [list git commit-tree $tree_id]
- set parents [concat $PARENT $MERGE_HEAD]
- if {[llength $parents] > 0} {
- foreach p $parents {
- lappend cmd -p $p
- }
- } else {
- # git commit-tree writes to stderr during initial commit.
- lappend cmd 2>/dev/null
- }
- lappend cmd <$msg_p
- if {[catch {set cmt_id [eval exec $cmd]} err]} {
- error_popup "commit-tree failed:\n\n$err"
- set ui_status_value {Commit failed.}
- unlock_index
- return
- }
-
- # -- Update the HEAD ref.
- #
- set reflogm commit
- if {$commit_type ne {normal}} {
- append reflogm " ($commit_type)"
- }
- set i [string first "\n" $msg]
- if {$i >= 0} {
- append reflogm {: } [string range $msg 0 [expr {$i - 1}]]
- } else {
- append reflogm {: } $msg
- }
- set cmd [list git update-ref -m $reflogm HEAD $cmt_id $curHEAD]
- if {[catch {eval exec $cmd} err]} {
- error_popup "update-ref failed:\n\n$err"
- set ui_status_value {Commit failed.}
- unlock_index
- return
- }
-
- # -- Make sure our current branch exists.
- #
- if {$commit_type eq {initial}} {
- lappend all_heads $current_branch
- set all_heads [lsort -unique $all_heads]
- populate_branch_menu
- }
-
- # -- Cleanup after ourselves.
- #
- catch {file delete $msg_p}
- catch {file delete [gitdir MERGE_HEAD]}
- catch {file delete [gitdir MERGE_MSG]}
- catch {file delete [gitdir SQUASH_MSG]}
- catch {file delete [gitdir GITGUI_MSG]}
-
- # -- Let rerere do its thing.
- #
- if {[file isdirectory [gitdir rr-cache]]} {
- catch {git rerere}
- }
-
- # -- Run the post-commit hook.
- #
- set pchook [gitdir hooks post-commit]
- if {[is_Cygwin] && [file isfile $pchook]} {
- set pchook [list sh -c [concat \
- "if test -x \"$pchook\";" \
- "then exec \"$pchook\";" \
- "fi"]]
- } elseif {![file executable $pchook]} {
- set pchook {}
- }
- if {$pchook ne {}} {
- catch {exec $pchook &}
- }
-
- $ui_comm delete 0.0 end
- $ui_comm edit reset
- $ui_comm edit modified false
-
- if {[is_enabled singlecommit]} do_quit
-
- # -- Update in memory status
- #
- set selected_commit_type new
- set commit_type normal
- set HEAD $cmt_id
- set PARENT $cmt_id
- set MERGE_HEAD [list]
-
- foreach path [array names file_states] {
- set s $file_states($path)
- set m [lindex $s 0]
- switch -glob -- $m {
- _O -
- _M -
- _D {continue}
- __ -
- A_ -
- M_ -
- D_ {
- unset file_states($path)
- catch {unset selected_paths($path)}
- }
- DO {
- set file_states($path) [list _O [lindex $s 1] {} {}]
- }
- AM -
- AD -
- MM -
- MD {
- set file_states($path) [list \
- _[string index $m 1] \
- [lindex $s 1] \
- [lindex $s 3] \
- {}]
- }
- }
- }
-
- display_all_files
- unlock_index
- reshow_diff
- set ui_status_value \
- "Changes committed as [string range $cmt_id 0 7]."
-}
-
-######################################################################
-##
-## fetch push
-
-proc fetch_from {remote} {
- set w [new_console \
- "fetch $remote" \
- "Fetching new changes from $remote"]
- set cmd [list git fetch]
- lappend cmd $remote
- console_exec $w $cmd console_done
-}
-
-proc push_to {remote} {
- set w [new_console \
- "push $remote" \
- "Pushing changes to $remote"]
- set cmd [list git push]
- lappend cmd -v
- lappend cmd $remote
- console_exec $w $cmd console_done
-}
-
-######################################################################
-##
-## ui helpers
-
-proc mapicon {w state path} {
- global all_icons
-
- if {[catch {set r $all_icons($state$w)}]} {
- puts "error: no icon for $w state={$state} $path"
- return file_plain
- }
- return $r
-}
-
-proc mapdesc {state path} {
- global all_descs
-
- if {[catch {set r $all_descs($state)}]} {
- puts "error: no desc for state={$state} $path"
- return $state
- }
- return $r
-}
-
-proc escape_path {path} {
- regsub -all {\\} $path "\\\\" path
- regsub -all "\n" $path "\\n" path
- return $path
-}
-
-proc short_path {path} {
- return [escape_path [lindex [file split $path] end]]
-}
-
-set next_icon_id 0
-set null_sha1 [string repeat 0 40]
-
-proc merge_state {path new_state {head_info {}} {index_info {}}} {
- global file_states next_icon_id null_sha1
-
- set s0 [string index $new_state 0]
- set s1 [string index $new_state 1]
-
- if {[catch {set info $file_states($path)}]} {
- set state __
- set icon n[incr next_icon_id]
- } else {
- set state [lindex $info 0]
- set icon [lindex $info 1]
- if {$head_info eq {}} {set head_info [lindex $info 2]}
- if {$index_info eq {}} {set index_info [lindex $info 3]}
- }
-
- if {$s0 eq {?}} {set s0 [string index $state 0]} \
- elseif {$s0 eq {_}} {set s0 _}
-
- if {$s1 eq {?}} {set s1 [string index $state 1]} \
- elseif {$s1 eq {_}} {set s1 _}
-
- if {$s0 eq {A} && $s1 eq {_} && $head_info eq {}} {
- set head_info [list 0 $null_sha1]
- } elseif {$s0 ne {_} && [string index $state 0] eq {_}
- && $head_info eq {}} {
- set head_info $index_info
- }
-
- set file_states($path) [list $s0$s1 $icon \
- $head_info $index_info \
- ]
- return $state
-}
-
-proc display_file_helper {w path icon_name old_m new_m} {
- global file_lists
-
- if {$new_m eq {_}} {
- set lno [lsearch -sorted -exact $file_lists($w) $path]
- if {$lno >= 0} {
- set file_lists($w) [lreplace $file_lists($w) $lno $lno]
- incr lno
- $w conf -state normal
- $w delete $lno.0 [expr {$lno + 1}].0
- $w conf -state disabled
- }
- } elseif {$old_m eq {_} && $new_m ne {_}} {
- lappend file_lists($w) $path
- set file_lists($w) [lsort -unique $file_lists($w)]
- set lno [lsearch -sorted -exact $file_lists($w) $path]
- incr lno
- $w conf -state normal
- $w image create $lno.0 \
- -align center -padx 5 -pady 1 \
- -name $icon_name \
- -image [mapicon $w $new_m $path]
- $w insert $lno.1 "[escape_path $path]\n"
- $w conf -state disabled
- } elseif {$old_m ne $new_m} {
- $w conf -state normal
- $w image conf $icon_name -image [mapicon $w $new_m $path]
- $w conf -state disabled
- }
-}
-
-proc display_file {path state} {
- global file_states selected_paths
- global ui_index ui_workdir
-
- set old_m [merge_state $path $state]
- set s $file_states($path)
- set new_m [lindex $s 0]
- set icon_name [lindex $s 1]
-
- set o [string index $old_m 0]
- set n [string index $new_m 0]
- if {$o eq {U}} {
- set o _
- }
- if {$n eq {U}} {
- set n _
- }
- display_file_helper $ui_index $path $icon_name $o $n
-
- if {[string index $old_m 0] eq {U}} {
- set o U
- } else {
- set o [string index $old_m 1]
- }
- if {[string index $new_m 0] eq {U}} {
- set n U
- } else {
- set n [string index $new_m 1]
- }
- display_file_helper $ui_workdir $path $icon_name $o $n
-
- if {$new_m eq {__}} {
- unset file_states($path)
- catch {unset selected_paths($path)}
- }
-}
-
-proc display_all_files_helper {w path icon_name m} {
- global file_lists
-
- lappend file_lists($w) $path
- set lno [expr {[lindex [split [$w index end] .] 0] - 1}]
- $w image create end \
- -align center -padx 5 -pady 1 \
- -name $icon_name \
- -image [mapicon $w $m $path]
- $w insert end "[escape_path $path]\n"
-}
-
-proc display_all_files {} {
- global ui_index ui_workdir
- global file_states file_lists
- global last_clicked
-
- $ui_index conf -state normal
- $ui_workdir conf -state normal
-
- $ui_index delete 0.0 end
- $ui_workdir delete 0.0 end
- set last_clicked {}
-
- set file_lists($ui_index) [list]
- set file_lists($ui_workdir) [list]
-
- foreach path [lsort [array names file_states]] {
- set s $file_states($path)
- set m [lindex $s 0]
- set icon_name [lindex $s 1]
-
- set s [string index $m 0]
- if {$s ne {U} && $s ne {_}} {
- display_all_files_helper $ui_index $path \
- $icon_name $s
- }
-
- if {[string index $m 0] eq {U}} {
- set s U
- } else {
- set s [string index $m 1]
- }
- if {$s ne {_}} {
- display_all_files_helper $ui_workdir $path \
- $icon_name $s
- }
- }
-
- $ui_index conf -state disabled
- $ui_workdir conf -state disabled
-}
-
-proc update_indexinfo {msg pathList after} {
- global update_index_cp ui_status_value
-
- if {![lock_index update]} return
-
- set update_index_cp 0
- set pathList [lsort $pathList]
- set totalCnt [llength $pathList]
- set batch [expr {int($totalCnt * .01) + 1}]
- if {$batch > 25} {set batch 25}
-
- set ui_status_value [format \
- "$msg... %i/%i files (%.2f%%)" \
- $update_index_cp \
- $totalCnt \
- 0.0]
- set fd [open "| git update-index -z --index-info" w]
- fconfigure $fd \
- -blocking 0 \
- -buffering full \
- -buffersize 512 \
- -encoding binary \
- -translation binary
- fileevent $fd writable [list \
- write_update_indexinfo \
- $fd \
- $pathList \
- $totalCnt \
- $batch \
- $msg \
- $after \
- ]
-}
-
-proc write_update_indexinfo {fd pathList totalCnt batch msg after} {
- global update_index_cp ui_status_value
- global file_states current_diff_path
-
- if {$update_index_cp >= $totalCnt} {
- close $fd
- unlock_index
- uplevel #0 $after
- return
- }
-
- for {set i $batch} \
- {$update_index_cp < $totalCnt && $i > 0} \
- {incr i -1} {
- set path [lindex $pathList $update_index_cp]
- incr update_index_cp
-
- set s $file_states($path)
- switch -glob -- [lindex $s 0] {
- A? {set new _O}
- M? {set new _M}
- D_ {set new _D}
- D? {set new _?}
- ?? {continue}
- }
- set info [lindex $s 2]
- if {$info eq {}} continue
-
- puts -nonewline $fd "$info\t[encoding convertto $path]\0"
- display_file $path $new
- }
-
- set ui_status_value [format \
- "$msg... %i/%i files (%.2f%%)" \
- $update_index_cp \
- $totalCnt \
- [expr {100.0 * $update_index_cp / $totalCnt}]]
-}
-
-proc update_index {msg pathList after} {
- global update_index_cp ui_status_value
-
- if {![lock_index update]} return
-
- set update_index_cp 0
- set pathList [lsort $pathList]
- set totalCnt [llength $pathList]
- set batch [expr {int($totalCnt * .01) + 1}]
- if {$batch > 25} {set batch 25}
-
- set ui_status_value [format \
- "$msg... %i/%i files (%.2f%%)" \
- $update_index_cp \
- $totalCnt \
- 0.0]
- set fd [open "| git update-index --add --remove -z --stdin" w]
- fconfigure $fd \
- -blocking 0 \
- -buffering full \
- -buffersize 512 \
- -encoding binary \
- -translation binary
- fileevent $fd writable [list \
- write_update_index \
- $fd \
- $pathList \
- $totalCnt \
- $batch \
- $msg \
- $after \
- ]
-}
-
-proc write_update_index {fd pathList totalCnt batch msg after} {
- global update_index_cp ui_status_value
- global file_states current_diff_path
-
- if {$update_index_cp >= $totalCnt} {
- close $fd
- unlock_index
- uplevel #0 $after
- return
- }
-
- for {set i $batch} \
- {$update_index_cp < $totalCnt && $i > 0} \
- {incr i -1} {
- set path [lindex $pathList $update_index_cp]
- incr update_index_cp
-
- switch -glob -- [lindex $file_states($path) 0] {
- AD {set new __}
- ?D {set new D_}
- _O -
- AM {set new A_}
- U? {
- if {[file exists $path]} {
- set new M_
- } else {
- set new D_
- }
- }
- ?M {set new M_}
- ?? {continue}
- }
- puts -nonewline $fd "[encoding convertto $path]\0"
- display_file $path $new
- }
-
- set ui_status_value [format \
- "$msg... %i/%i files (%.2f%%)" \
- $update_index_cp \
- $totalCnt \
- [expr {100.0 * $update_index_cp / $totalCnt}]]
-}
-
-proc checkout_index {msg pathList after} {
- global update_index_cp ui_status_value
-
- if {![lock_index update]} return
-
- set update_index_cp 0
- set pathList [lsort $pathList]
- set totalCnt [llength $pathList]
- set batch [expr {int($totalCnt * .01) + 1}]
- if {$batch > 25} {set batch 25}
-
- set ui_status_value [format \
- "$msg... %i/%i files (%.2f%%)" \
- $update_index_cp \
- $totalCnt \
- 0.0]
- set cmd [list git checkout-index]
- lappend cmd --index
- lappend cmd --quiet
- lappend cmd --force
- lappend cmd -z
- lappend cmd --stdin
- set fd [open "| $cmd " w]
- fconfigure $fd \
- -blocking 0 \
- -buffering full \
- -buffersize 512 \
- -encoding binary \
- -translation binary
- fileevent $fd writable [list \
- write_checkout_index \
- $fd \
- $pathList \
- $totalCnt \
- $batch \
- $msg \
- $after \
- ]
-}
-
-proc write_checkout_index {fd pathList totalCnt batch msg after} {
- global update_index_cp ui_status_value
- global file_states current_diff_path
-
- if {$update_index_cp >= $totalCnt} {
- close $fd
- unlock_index
- uplevel #0 $after
- return
- }
-
- for {set i $batch} \
- {$update_index_cp < $totalCnt && $i > 0} \
- {incr i -1} {
- set path [lindex $pathList $update_index_cp]
- incr update_index_cp
- switch -glob -- [lindex $file_states($path) 0] {
- U? {continue}
- ?M -
- ?D {
- puts -nonewline $fd "[encoding convertto $path]\0"
- display_file $path ?_
- }
- }
- }
-
- set ui_status_value [format \
- "$msg... %i/%i files (%.2f%%)" \
- $update_index_cp \
- $totalCnt \
- [expr {100.0 * $update_index_cp / $totalCnt}]]
-}
-
-######################################################################
-##
-## branch management
-
-proc is_tracking_branch {name} {
- global tracking_branches
-
- if {![catch {set info $tracking_branches($name)}]} {
- return 1
- }
- foreach t [array names tracking_branches] {
- if {[string match {*/\*} $t] && [string match $t $name]} {
- return 1
- }
- }
- return 0
-}
-
-proc load_all_heads {} {
- global all_heads
-
- set all_heads [list]
- set fd [open "| git for-each-ref --format=%(refname) refs/heads" r]
- while {[gets $fd line] > 0} {
- if {[is_tracking_branch $line]} continue
- if {![regsub ^refs/heads/ $line {} name]} continue
- lappend all_heads $name
- }
- close $fd
-
- set all_heads [lsort $all_heads]
-}
-
-proc populate_branch_menu {} {
- global all_heads disable_on_lock
-
- set m .mbar.branch
- set last [$m index last]
- for {set i 0} {$i <= $last} {incr i} {
- if {[$m type $i] eq {separator}} {
- $m delete $i last
- set new_dol [list]
- foreach a $disable_on_lock {
- if {[lindex $a 0] ne $m || [lindex $a 2] < $i} {
- lappend new_dol $a
- }
- }
- set disable_on_lock $new_dol
- break
- }
- }
-
- if {$all_heads ne {}} {
- $m add separator
- }
- foreach b $all_heads {
- $m add radiobutton \
- -label $b \
- -command [list switch_branch $b] \
- -variable current_branch \
- -value $b \
- -font font_ui
- lappend disable_on_lock \
- [list $m entryconf [$m index last] -state]
- }
-}
-
-proc all_tracking_branches {} {
- global tracking_branches
-
- set all_trackings {}
- set cmd {}
- foreach name [array names tracking_branches] {
- if {[regsub {/\*$} $name {} name]} {
- lappend cmd $name
- } else {
- regsub ^refs/(heads|remotes)/ $name {} name
- lappend all_trackings $name
- }
- }
-
- if {$cmd ne {}} {
- set fd [open "| git for-each-ref --format=%(refname) $cmd" r]
- while {[gets $fd name] > 0} {
- regsub ^refs/(heads|remotes)/ $name {} name
- lappend all_trackings $name
- }
- close $fd
- }
-
- return [lsort -unique $all_trackings]
-}
-
-proc load_all_tags {} {
- set all_tags [list]
- set fd [open "| git for-each-ref --format=%(refname) refs/tags" r]
- while {[gets $fd line] > 0} {
- if {![regsub ^refs/tags/ $line {} name]} continue
- lappend all_tags $name
- }
- close $fd
-
- return [lsort $all_tags]
-}
-
-proc do_create_branch_action {w} {
- global all_heads null_sha1 repo_config
- global create_branch_checkout create_branch_revtype
- global create_branch_head create_branch_trackinghead
- global create_branch_name create_branch_revexp
- global create_branch_tag
-
- set newbranch $create_branch_name
- if {$newbranch eq {}
- || $newbranch eq $repo_config(gui.newbranchtemplate)} {
- tk_messageBox \
- -icon error \
- -type ok \
- -title [wm title $w] \
- -parent $w \
- -message "Please supply a branch name."
- focus $w.desc.name_t
- return
- }
- if {![catch {git show-ref --verify -- "refs/heads/$newbranch"}]} {
- tk_messageBox \
- -icon error \
- -type ok \
- -title [wm title $w] \
- -parent $w \
- -message "Branch '$newbranch' already exists."
- focus $w.desc.name_t
- return
- }
- if {[catch {git check-ref-format "heads/$newbranch"}]} {
- tk_messageBox \
- -icon error \
- -type ok \
- -title [wm title $w] \
- -parent $w \
- -message "We do not like '$newbranch' as a branch name."
- focus $w.desc.name_t
- return
- }
-
- set rev {}
- switch -- $create_branch_revtype {
- head {set rev $create_branch_head}
- tracking {set rev $create_branch_trackinghead}
- tag {set rev $create_branch_tag}
- expression {set rev $create_branch_revexp}
- }
- if {[catch {set cmt [git rev-parse --verify "${rev}^0"]}]} {
- tk_messageBox \
- -icon error \
- -type ok \
- -title [wm title $w] \
- -parent $w \
- -message "Invalid starting revision: $rev"
- return
- }
- set cmd [list git update-ref]
- lappend cmd -m
- lappend cmd "branch: Created from $rev"
- lappend cmd "refs/heads/$newbranch"
- lappend cmd $cmt
- lappend cmd $null_sha1
- if {[catch {eval exec $cmd} err]} {
- tk_messageBox \
- -icon error \
- -type ok \
- -title [wm title $w] \
- -parent $w \
- -message "Failed to create '$newbranch'.\n\n$err"
- return
- }
-
- lappend all_heads $newbranch
- set all_heads [lsort $all_heads]
- populate_branch_menu
- destroy $w
- if {$create_branch_checkout} {
- switch_branch $newbranch
- }
-}
-
-proc radio_selector {varname value args} {
- upvar #0 $varname var
- set var $value
-}
-
-trace add variable create_branch_head write \
- [list radio_selector create_branch_revtype head]
-trace add variable create_branch_trackinghead write \
- [list radio_selector create_branch_revtype tracking]
-trace add variable create_branch_tag write \
- [list radio_selector create_branch_revtype tag]
-
-trace add variable delete_branch_head write \
- [list radio_selector delete_branch_checktype head]
-trace add variable delete_branch_trackinghead write \
- [list radio_selector delete_branch_checktype tracking]
-
-proc do_create_branch {} {
- global all_heads current_branch repo_config
- global create_branch_checkout create_branch_revtype
- global create_branch_head create_branch_trackinghead
- global create_branch_name create_branch_revexp
- global create_branch_tag
-
- set w .branch_editor
- toplevel $w
- wm geometry $w "+[winfo rootx .]+[winfo rooty .]"
-
- label $w.header -text {Create New Branch} \
- -font font_uibold
- pack $w.header -side top -fill x
-
- frame $w.buttons
- button $w.buttons.create -text Create \
- -font font_ui \
- -default active \
- -command [list do_create_branch_action $w]
- pack $w.buttons.create -side right
- button $w.buttons.cancel -text {Cancel} \
- -font font_ui \
- -command [list destroy $w]
- pack $w.buttons.cancel -side right -padx 5
- pack $w.buttons -side bottom -fill x -pady 10 -padx 10
-
- labelframe $w.desc \
- -text {Branch Description} \
- -font font_ui
- label $w.desc.name_l -text {Name:} -font font_ui
- entry $w.desc.name_t \
- -borderwidth 1 \
- -relief sunken \
- -width 40 \
- -textvariable create_branch_name \
- -font font_ui \
- -validate key \
- -validatecommand {
- if {%d == 1 && [regexp {[~^:?*\[\0- ]} %S]} {return 0}
- return 1
- }
- grid $w.desc.name_l $w.desc.name_t -sticky we -padx {0 5}
- grid columnconfigure $w.desc 1 -weight 1
- pack $w.desc -anchor nw -fill x -pady 5 -padx 5
-
- labelframe $w.from \
- -text {Starting Revision} \
- -font font_ui
- radiobutton $w.from.head_r \
- -text {Local Branch:} \
- -value head \
- -variable create_branch_revtype \
- -font font_ui
- eval tk_optionMenu $w.from.head_m create_branch_head $all_heads
- grid $w.from.head_r $w.from.head_m -sticky w
- set all_trackings [all_tracking_branches]
- if {$all_trackings ne {}} {
- set create_branch_trackinghead [lindex $all_trackings 0]
- radiobutton $w.from.tracking_r \
- -text {Tracking Branch:} \
- -value tracking \
- -variable create_branch_revtype \
- -font font_ui
- eval tk_optionMenu $w.from.tracking_m \
- create_branch_trackinghead \
- $all_trackings
- grid $w.from.tracking_r $w.from.tracking_m -sticky w
- }
- set all_tags [load_all_tags]
- if {$all_tags ne {}} {
- set create_branch_tag [lindex $all_tags 0]
- radiobutton $w.from.tag_r \
- -text {Tag:} \
- -value tag \
- -variable create_branch_revtype \
- -font font_ui
- eval tk_optionMenu $w.from.tag_m \
- create_branch_tag \
- $all_tags
- grid $w.from.tag_r $w.from.tag_m -sticky w
- }
- radiobutton $w.from.exp_r \
- -text {Revision Expression:} \
- -value expression \
- -variable create_branch_revtype \
- -font font_ui
- entry $w.from.exp_t \
- -borderwidth 1 \
- -relief sunken \
- -width 50 \
- -textvariable create_branch_revexp \
- -font font_ui \
- -validate key \
- -validatecommand {
- if {%d == 1 && [regexp {\s} %S]} {return 0}
- if {%d == 1 && [string length %S] > 0} {
- set create_branch_revtype expression
- }
- return 1
- }
- grid $w.from.exp_r $w.from.exp_t -sticky we -padx {0 5}
- grid columnconfigure $w.from 1 -weight 1
- pack $w.from -anchor nw -fill x -pady 5 -padx 5
-
- labelframe $w.postActions \
- -text {Post Creation Actions} \
- -font font_ui
- checkbutton $w.postActions.checkout \
- -text {Checkout after creation} \
- -variable create_branch_checkout \
- -font font_ui
- pack $w.postActions.checkout -anchor nw
- pack $w.postActions -anchor nw -fill x -pady 5 -padx 5
-
- set create_branch_checkout 1
- set create_branch_head $current_branch
- set create_branch_revtype head
- set create_branch_name $repo_config(gui.newbranchtemplate)
- set create_branch_revexp {}
-
- bind $w <Visibility> "
- grab $w
- $w.desc.name_t icursor end
- focus $w.desc.name_t
- "
- bind $w <Key-Escape> "destroy $w"
- bind $w <Key-Return> "do_create_branch_action $w;break"
- wm title $w "[appname] ([reponame]): Create Branch"
- tkwait window $w
-}
-
-proc do_delete_branch_action {w} {
- global all_heads
- global delete_branch_checktype delete_branch_head delete_branch_trackinghead
-
- set check_rev {}
- switch -- $delete_branch_checktype {
- head {set check_rev $delete_branch_head}
- tracking {set check_rev $delete_branch_trackinghead}
- always {set check_rev {:none}}
- }
- if {$check_rev eq {:none}} {
- set check_cmt {}
- } elseif {[catch {set check_cmt [git rev-parse --verify "${check_rev}^0"]}]} {
- tk_messageBox \
- -icon error \
- -type ok \
- -title [wm title $w] \
- -parent $w \
- -message "Invalid check revision: $check_rev"
- return
- }
-
- set to_delete [list]
- set not_merged [list]
- foreach i [$w.list.l curselection] {
- set b [$w.list.l get $i]
- if {[catch {set o [git rev-parse --verify $b]}]} continue
- if {$check_cmt ne {}} {
- if {$b eq $check_rev} continue
- if {[catch {set m [git merge-base $o $check_cmt]}]} continue
- if {$o ne $m} {
- lappend not_merged $b
- continue
- }
- }
- lappend to_delete [list $b $o]
- }
- if {$not_merged ne {}} {
- set msg "The following branches are not completely merged into $check_rev:
-
- - [join $not_merged "\n - "]"
- tk_messageBox \
- -icon info \
- -type ok \
- -title [wm title $w] \
- -parent $w \
- -message $msg
- }
- if {$to_delete eq {}} return
- if {$delete_branch_checktype eq {always}} {
- set msg {Recovering deleted branches is difficult.
-
-Delete the selected branches?}
- if {[tk_messageBox \
- -icon warning \
- -type yesno \
- -title [wm title $w] \
- -parent $w \
- -message $msg] ne yes} {
- return
- }
- }
-
- set failed {}
- foreach i $to_delete {
- set b [lindex $i 0]
- set o [lindex $i 1]
- if {[catch {git update-ref -d "refs/heads/$b" $o} err]} {
- append failed " - $b: $err\n"
- } else {
- set x [lsearch -sorted -exact $all_heads $b]
- if {$x >= 0} {
- set all_heads [lreplace $all_heads $x $x]
- }
- }
- }
-
- if {$failed ne {}} {
- tk_messageBox \
- -icon error \
- -type ok \
- -title [wm title $w] \
- -parent $w \
- -message "Failed to delete branches:\n$failed"
- }
-
- set all_heads [lsort $all_heads]
- populate_branch_menu
- destroy $w
-}
-
-proc do_delete_branch {} {
- global all_heads tracking_branches current_branch
- global delete_branch_checktype delete_branch_head delete_branch_trackinghead
-
- set w .branch_editor
- toplevel $w
- wm geometry $w "+[winfo rootx .]+[winfo rooty .]"
-
- label $w.header -text {Delete Local Branch} \
- -font font_uibold
- pack $w.header -side top -fill x
-
- frame $w.buttons
- button $w.buttons.create -text Delete \
- -font font_ui \
- -command [list do_delete_branch_action $w]
- pack $w.buttons.create -side right
- button $w.buttons.cancel -text {Cancel} \
- -font font_ui \
- -command [list destroy $w]
- pack $w.buttons.cancel -side right -padx 5
- pack $w.buttons -side bottom -fill x -pady 10 -padx 10
-
- labelframe $w.list \
- -text {Local Branches} \
- -font font_ui
- listbox $w.list.l \
- -height 10 \
- -width 70 \
- -selectmode extended \
- -yscrollcommand [list $w.list.sby set] \
- -font font_ui
- foreach h $all_heads {
- if {$h ne $current_branch} {
- $w.list.l insert end $h
- }
- }
- scrollbar $w.list.sby -command [list $w.list.l yview]
- pack $w.list.sby -side right -fill y
- pack $w.list.l -side left -fill both -expand 1
- pack $w.list -fill both -expand 1 -pady 5 -padx 5
-
- labelframe $w.validate \
- -text {Delete Only If} \
- -font font_ui
- radiobutton $w.validate.head_r \
- -text {Merged Into Local Branch:} \
- -value head \
- -variable delete_branch_checktype \
- -font font_ui
- eval tk_optionMenu $w.validate.head_m delete_branch_head $all_heads
- grid $w.validate.head_r $w.validate.head_m -sticky w
- set all_trackings [all_tracking_branches]
- if {$all_trackings ne {}} {
- set delete_branch_trackinghead [lindex $all_trackings 0]
- radiobutton $w.validate.tracking_r \
- -text {Merged Into Tracking Branch:} \
- -value tracking \
- -variable delete_branch_checktype \
- -font font_ui
- eval tk_optionMenu $w.validate.tracking_m \
- delete_branch_trackinghead \
- $all_trackings
- grid $w.validate.tracking_r $w.validate.tracking_m -sticky w
- }
- radiobutton $w.validate.always_r \
- -text {Always (Do not perform merge checks)} \
- -value always \
- -variable delete_branch_checktype \
- -font font_ui
- grid $w.validate.always_r -columnspan 2 -sticky w
- grid columnconfigure $w.validate 1 -weight 1
- pack $w.validate -anchor nw -fill x -pady 5 -padx 5
-
- set delete_branch_head $current_branch
- set delete_branch_checktype head
-
- bind $w <Visibility> "grab $w; focus $w"
- bind $w <Key-Escape> "destroy $w"
- wm title $w "[appname] ([reponame]): Delete Branch"
- tkwait window $w
-}
-
-proc switch_branch {new_branch} {
- global HEAD commit_type current_branch repo_config
-
- if {![lock_index switch]} return
-
- # -- Our in memory state should match the repository.
- #
- repository_state curType curHEAD curMERGE_HEAD
- if {[string match amend* $commit_type]
- && $curType eq {normal}
- && $curHEAD eq $HEAD} {
- } elseif {$commit_type ne $curType || $HEAD ne $curHEAD} {
- info_popup {Last scanned state does not match repository state.
-
-Another Git program has modified this repository
-since the last scan. A rescan must be performed
-before the current branch can be changed.
-
-The rescan will be automatically started now.
-}
- unlock_index
- rescan {set ui_status_value {Ready.}}
- return
- }
-
- # -- Don't do a pointless switch.
- #
- if {$current_branch eq $new_branch} {
- unlock_index
- return
- }
-
- if {$repo_config(gui.trustmtime) eq {true}} {
- switch_branch_stage2 {} $new_branch
- } else {
- set ui_status_value {Refreshing file status...}
- set cmd [list git update-index]
- lappend cmd -q
- lappend cmd --unmerged
- lappend cmd --ignore-missing
- lappend cmd --refresh
- set fd_rf [open "| $cmd" r]
- fconfigure $fd_rf -blocking 0 -translation binary
- fileevent $fd_rf readable \
- [list switch_branch_stage2 $fd_rf $new_branch]
- }
-}
-
-proc switch_branch_stage2 {fd_rf new_branch} {
- global ui_status_value HEAD
-
- if {$fd_rf ne {}} {
- read $fd_rf
- if {![eof $fd_rf]} return
- close $fd_rf
- }
-
- set ui_status_value "Updating working directory to '$new_branch'..."
- set cmd [list git read-tree]
- lappend cmd -m
- lappend cmd -u
- lappend cmd --exclude-per-directory=.gitignore
- lappend cmd $HEAD
- lappend cmd $new_branch
- set fd_rt [open "| $cmd" r]
- fconfigure $fd_rt -blocking 0 -translation binary
- fileevent $fd_rt readable \
- [list switch_branch_readtree_wait $fd_rt $new_branch]
-}
-
-proc switch_branch_readtree_wait {fd_rt new_branch} {
- global selected_commit_type commit_type HEAD MERGE_HEAD PARENT
- global current_branch
- global ui_comm ui_status_value
-
- # -- We never get interesting output on stdout; only stderr.
- #
- read $fd_rt
- fconfigure $fd_rt -blocking 1
- if {![eof $fd_rt]} {
- fconfigure $fd_rt -blocking 0
- return
- }
-
- # -- The working directory wasn't in sync with the index and
- # we'd have to overwrite something to make the switch. A
- # merge is required.
- #
- if {[catch {close $fd_rt} err]} {
- regsub {^fatal: } $err {} err
- warn_popup "File level merge required.
-
-$err
-
-Staying on branch '$current_branch'."
- set ui_status_value "Aborted checkout of '$new_branch' (file level merging is required)."
- unlock_index
- return
- }
-
- # -- Update the symbolic ref. Core git doesn't even check for failure
- # here, it Just Works(tm). If it doesn't we are in some really ugly
- # state that is difficult to recover from within git-gui.
- #
- if {[catch {git symbolic-ref HEAD "refs/heads/$new_branch"} err]} {
- error_popup "Failed to set current branch.
-
-This working directory is only partially switched.
-We successfully updated your files, but failed to
-update an internal Git file.
-
-This should not have occurred. [appname] will now
-close and give up.
-
-$err"
- do_quit
- return
- }
-
- # -- Update our repository state. If we were previously in amend mode
- # we need to toss the current buffer and do a full rescan to update
- # our file lists. If we weren't in amend mode our file lists are
- # accurate and we can avoid the rescan.
- #
- unlock_index
- set selected_commit_type new
- if {[string match amend* $commit_type]} {
- $ui_comm delete 0.0 end
- $ui_comm edit reset
- $ui_comm edit modified false
- rescan {set ui_status_value "Checked out branch '$current_branch'."}
- } else {
- repository_state commit_type HEAD MERGE_HEAD
- set PARENT $HEAD
- set ui_status_value "Checked out branch '$current_branch'."
- }
-}
-
-######################################################################
-##
-## remote management
-
-proc load_all_remotes {} {
- global repo_config
- global all_remotes tracking_branches
-
- set all_remotes [list]
- array unset tracking_branches
-
- set rm_dir [gitdir remotes]
- if {[file isdirectory $rm_dir]} {
- set all_remotes [glob \
- -types f \
- -tails \
- -nocomplain \
- -directory $rm_dir *]
-
- foreach name $all_remotes {
- catch {
- set fd [open [file join $rm_dir $name] r]
- while {[gets $fd line] >= 0} {
- if {![regexp {^Pull:[ ]*([^:]+):(.+)$} \
- $line line src dst]} continue
- if {![regexp ^refs/ $dst]} {
- set dst "refs/heads/$dst"
- }
- set tracking_branches($dst) [list $name $src]
- }
- close $fd
- }
- }
- }
-
- foreach line [array names repo_config remote.*.url] {
- if {![regexp ^remote\.(.*)\.url\$ $line line name]} continue
- lappend all_remotes $name
-
- if {[catch {set fl $repo_config(remote.$name.fetch)}]} {
- set fl {}
- }
- foreach line $fl {
- if {![regexp {^([^:]+):(.+)$} $line line src dst]} continue
- if {![regexp ^refs/ $dst]} {
- set dst "refs/heads/$dst"
- }
- set tracking_branches($dst) [list $name $src]
- }
- }
-
- set all_remotes [lsort -unique $all_remotes]
-}
-
-proc populate_fetch_menu {} {
- global all_remotes repo_config
-
- set m .mbar.fetch
- foreach r $all_remotes {
- set enable 0
- if {![catch {set a $repo_config(remote.$r.url)}]} {
- if {![catch {set a $repo_config(remote.$r.fetch)}]} {
- set enable 1
- }
- } else {
- catch {
- set fd [open [gitdir remotes $r] r]
- while {[gets $fd n] >= 0} {
- if {[regexp {^Pull:[ \t]*([^:]+):} $n]} {
- set enable 1
- break
- }
- }
- close $fd
- }
- }
-
- if {$enable} {
- $m add command \
- -label "Fetch from $r..." \
- -command [list fetch_from $r] \
- -font font_ui
- }
- }
-}
-
-proc populate_push_menu {} {
- global all_remotes repo_config
-
- set m .mbar.push
- set fast_count 0
- foreach r $all_remotes {
- set enable 0
- if {![catch {set a $repo_config(remote.$r.url)}]} {
- if {![catch {set a $repo_config(remote.$r.push)}]} {
- set enable 1
- }
- } else {
- catch {
- set fd [open [gitdir remotes $r] r]
- while {[gets $fd n] >= 0} {
- if {[regexp {^Push:[ \t]*([^:]+):} $n]} {
- set enable 1
- break
- }
- }
- close $fd
- }
- }
-
- if {$enable} {
- if {!$fast_count} {
- $m add separator
- }
- $m add command \
- -label "Push to $r..." \
- -command [list push_to $r] \
- -font font_ui
- incr fast_count
- }
- }
-}
-
-proc start_push_anywhere_action {w} {
- global push_urltype push_remote push_url push_thin push_tags
-
- set r_url {}
- switch -- $push_urltype {
- remote {set r_url $push_remote}
- url {set r_url $push_url}
- }
- if {$r_url eq {}} return
-
- set cmd [list git push]
- lappend cmd -v
- if {$push_thin} {
- lappend cmd --thin
- }
- if {$push_tags} {
- lappend cmd --tags
- }
- lappend cmd $r_url
- set cnt 0
- foreach i [$w.source.l curselection] {
- set b [$w.source.l get $i]
- lappend cmd "refs/heads/$b:refs/heads/$b"
- incr cnt
- }
- if {$cnt == 0} {
- return
- } elseif {$cnt == 1} {
- set unit branch
- } else {
- set unit branches
- }
-
- set cons [new_console "push $r_url" "Pushing $cnt $unit to $r_url"]
- console_exec $cons $cmd console_done
- destroy $w
-}
-
-trace add variable push_remote write \
- [list radio_selector push_urltype remote]
-
-proc do_push_anywhere {} {
- global all_heads all_remotes current_branch
- global push_urltype push_remote push_url push_thin push_tags
-
- set w .push_setup
- toplevel $w
- wm geometry $w "+[winfo rootx .]+[winfo rooty .]"
-
- label $w.header -text {Push Branches} -font font_uibold
- pack $w.header -side top -fill x
-
- frame $w.buttons
- button $w.buttons.create -text Push \
- -font font_ui \
- -command [list start_push_anywhere_action $w]
- pack $w.buttons.create -side right
- button $w.buttons.cancel -text {Cancel} \
- -font font_ui \
- -command [list destroy $w]
- pack $w.buttons.cancel -side right -padx 5
- pack $w.buttons -side bottom -fill x -pady 10 -padx 10
-
- labelframe $w.source \
- -text {Source Branches} \
- -font font_ui
- listbox $w.source.l \
- -height 10 \
- -width 70 \
- -selectmode extended \
- -yscrollcommand [list $w.source.sby set] \
- -font font_ui
- foreach h $all_heads {
- $w.source.l insert end $h
- if {$h eq $current_branch} {
- $w.source.l select set end
- }
- }
- scrollbar $w.source.sby -command [list $w.source.l yview]
- pack $w.source.sby -side right -fill y
- pack $w.source.l -side left -fill both -expand 1
- pack $w.source -fill both -expand 1 -pady 5 -padx 5
-
- labelframe $w.dest \
- -text {Destination Repository} \
- -font font_ui
- if {$all_remotes ne {}} {
- radiobutton $w.dest.remote_r \
- -text {Remote:} \
- -value remote \
- -variable push_urltype \
- -font font_ui
- eval tk_optionMenu $w.dest.remote_m push_remote $all_remotes
- grid $w.dest.remote_r $w.dest.remote_m -sticky w
- if {[lsearch -sorted -exact $all_remotes origin] != -1} {
- set push_remote origin
- } else {
- set push_remote [lindex $all_remotes 0]
- }
- set push_urltype remote
- } else {
- set push_urltype url
- }
- radiobutton $w.dest.url_r \
- -text {Arbitrary URL:} \
- -value url \
- -variable push_urltype \
- -font font_ui
- entry $w.dest.url_t \
- -borderwidth 1 \
- -relief sunken \
- -width 50 \
- -textvariable push_url \
- -font font_ui \
- -validate key \
- -validatecommand {
- if {%d == 1 && [regexp {\s} %S]} {return 0}
- if {%d == 1 && [string length %S] > 0} {
- set push_urltype url
- }
- return 1
- }
- grid $w.dest.url_r $w.dest.url_t -sticky we -padx {0 5}
- grid columnconfigure $w.dest 1 -weight 1
- pack $w.dest -anchor nw -fill x -pady 5 -padx 5
-
- labelframe $w.options \
- -text {Transfer Options} \
- -font font_ui
- checkbutton $w.options.thin \
- -text {Use thin pack (for slow network connections)} \
- -variable push_thin \
- -font font_ui
- grid $w.options.thin -columnspan 2 -sticky w
- checkbutton $w.options.tags \
- -text {Include tags} \
- -variable push_tags \
- -font font_ui
- grid $w.options.tags -columnspan 2 -sticky w
- grid columnconfigure $w.options 1 -weight 1
- pack $w.options -anchor nw -fill x -pady 5 -padx 5
-
- set push_url {}
- set push_thin 0
- set push_tags 0
-
- bind $w <Visibility> "grab $w"
- bind $w <Key-Escape> "destroy $w"
- wm title $w "[appname] ([reponame]): Push"
- tkwait window $w
-}
-
-######################################################################
-##
-## merge
-
-proc can_merge {} {
- global HEAD commit_type file_states
-
- if {[string match amend* $commit_type]} {
- info_popup {Cannot merge while amending.
-
-You must finish amending this commit before
-starting any type of merge.
-}
- return 0
- }
-
- if {[committer_ident] eq {}} {return 0}
- if {![lock_index merge]} {return 0}
-
- # -- Our in memory state should match the repository.
- #
- repository_state curType curHEAD curMERGE_HEAD
- if {$commit_type ne $curType || $HEAD ne $curHEAD} {
- info_popup {Last scanned state does not match repository state.
-
-Another Git program has modified this repository
-since the last scan. A rescan must be performed
-before a merge can be performed.
-
-The rescan will be automatically started now.
-}
- unlock_index
- rescan {set ui_status_value {Ready.}}
- return 0
- }
-
- foreach path [array names file_states] {
- switch -glob -- [lindex $file_states($path) 0] {
- _O {
- continue; # and pray it works!
- }
- U? {
- error_popup "You are in the middle of a conflicted merge.
-
-File [short_path $path] has merge conflicts.
-
-You must resolve them, add the file, and commit to
-complete the current merge. Only then can you
-begin another merge.
-"
- unlock_index
- return 0
- }
- ?? {
- error_popup "You are in the middle of a change.
-
-File [short_path $path] is modified.
-
-You should complete the current commit before
-starting a merge. Doing so will help you abort
-a failed merge, should the need arise.
-"
- unlock_index
- return 0
- }
- }
- }
-
- return 1
-}
-
-proc visualize_local_merge {w} {
- set revs {}
- foreach i [$w.source.l curselection] {
- lappend revs [$w.source.l get $i]
- }
- if {$revs eq {}} return
- lappend revs --not HEAD
- do_gitk $revs
-}
-
-proc start_local_merge_action {w} {
- global HEAD ui_status_value current_branch
-
- set cmd [list git merge]
- set names {}
- set revcnt 0
- foreach i [$w.source.l curselection] {
- set b [$w.source.l get $i]
- lappend cmd $b
- lappend names $b
- incr revcnt
- }
-
- if {$revcnt == 0} {
- return
- } elseif {$revcnt == 1} {
- set unit branch
- } elseif {$revcnt <= 15} {
- set unit branches
- } else {
- tk_messageBox \
- -icon error \
- -type ok \
- -title [wm title $w] \
- -parent $w \
- -message "Too many branches selected.
-
-You have requested to merge $revcnt branches
-in an octopus merge. This exceeds Git's
-internal limit of 15 branches per merge.
-
-Please select fewer branches. To merge more
-than 15 branches, merge the branches in batches.
-"
- return
- }
-
- set msg "Merging $current_branch, [join $names {, }]"
- set ui_status_value "$msg..."
- set cons [new_console "Merge" $msg]
- console_exec $cons $cmd [list finish_merge $revcnt]
- bind $w <Destroy> {}
- destroy $w
-}
-
-proc finish_merge {revcnt w ok} {
- console_done $w $ok
- if {$ok} {
- set msg {Merge completed successfully.}
- } else {
- if {$revcnt != 1} {
- info_popup "Octopus merge failed.
-
-Your merge of $revcnt branches has failed.
-
-There are file-level conflicts between the
-branches which must be resolved manually.
-
-The working directory will now be reset.
-
-You can attempt this merge again
-by merging only one branch at a time." $w
-
- set fd [open "| git read-tree --reset -u HEAD" r]
- fconfigure $fd -blocking 0 -translation binary
- fileevent $fd readable [list reset_hard_wait $fd]
- set ui_status_value {Aborting... please wait...}
- return
- }
-
- set msg {Merge failed. Conflict resolution is required.}
- }
- unlock_index
- rescan [list set ui_status_value $msg]
-}
-
-proc do_local_merge {} {
- global current_branch
-
- if {![can_merge]} return
-
- set w .merge_setup
- toplevel $w
- wm geometry $w "+[winfo rootx .]+[winfo rooty .]"
-
- label $w.header \
- -text "Merge Into $current_branch" \
- -font font_uibold
- pack $w.header -side top -fill x
-
- frame $w.buttons
- button $w.buttons.visualize -text Visualize \
- -font font_ui \
- -command [list visualize_local_merge $w]
- pack $w.buttons.visualize -side left
- button $w.buttons.create -text Merge \
- -font font_ui \
- -command [list start_local_merge_action $w]
- pack $w.buttons.create -side right
- button $w.buttons.cancel -text {Cancel} \
- -font font_ui \
- -command [list destroy $w]
- pack $w.buttons.cancel -side right -padx 5
- pack $w.buttons -side bottom -fill x -pady 10 -padx 10
-
- labelframe $w.source \
- -text {Source Branches} \
- -font font_ui
- listbox $w.source.l \
- -height 10 \
- -width 70 \
- -selectmode extended \
- -yscrollcommand [list $w.source.sby set] \
- -font font_ui
- scrollbar $w.source.sby -command [list $w.source.l yview]
- pack $w.source.sby -side right -fill y
- pack $w.source.l -side left -fill both -expand 1
- pack $w.source -fill both -expand 1 -pady 5 -padx 5
-
- set cmd [list git for-each-ref]
- lappend cmd {--format=%(objectname) %(*objectname) %(refname)}
- lappend cmd refs/heads
- lappend cmd refs/remotes
- lappend cmd refs/tags
- set fr_fd [open "| $cmd" r]
- fconfigure $fr_fd -translation binary
- while {[gets $fr_fd line] > 0} {
- set line [split $line { }]
- set sha1([lindex $line 0]) [lindex $line 2]
- set sha1([lindex $line 1]) [lindex $line 2]
- }
- close $fr_fd
-
- set to_show {}
- set fr_fd [open "| git rev-list --all --not HEAD"]
- while {[gets $fr_fd line] > 0} {
- if {[catch {set ref $sha1($line)}]} continue
- regsub ^refs/(heads|remotes|tags)/ $ref {} ref
- lappend to_show $ref
- }
- close $fr_fd
-
- foreach ref [lsort -unique $to_show] {
- $w.source.l insert end $ref
- }
-
- bind $w <Visibility> "grab $w"
- bind $w <Key-Escape> "unlock_index;destroy $w"
- bind $w <Destroy> unlock_index
- wm title $w "[appname] ([reponame]): Merge"
- tkwait window $w
-}
-
-proc do_reset_hard {} {
- global HEAD commit_type file_states
-
- if {[string match amend* $commit_type]} {
- info_popup {Cannot abort while amending.
-
-You must finish amending this commit.
-}
- return
- }
-
- if {![lock_index abort]} return
-
- if {[string match *merge* $commit_type]} {
- set op merge
- } else {
- set op commit
- }
-
- if {[ask_popup "Abort $op?
-
-Aborting the current $op will cause
-*ALL* uncommitted changes to be lost.
-
-Continue with aborting the current $op?"] eq {yes}} {
- set fd [open "| git read-tree --reset -u HEAD" r]
- fconfigure $fd -blocking 0 -translation binary
- fileevent $fd readable [list reset_hard_wait $fd]
- set ui_status_value {Aborting... please wait...}
- } else {
- unlock_index
- }
-}
-
-proc reset_hard_wait {fd} {
- global ui_comm
-
- read $fd
- if {[eof $fd]} {
- close $fd
- unlock_index
-
- $ui_comm delete 0.0 end
- $ui_comm edit modified false
-
- catch {file delete [gitdir MERGE_HEAD]}
- catch {file delete [gitdir rr-cache MERGE_RR]}
- catch {file delete [gitdir SQUASH_MSG]}
- catch {file delete [gitdir MERGE_MSG]}
- catch {file delete [gitdir GITGUI_MSG]}
-
- rescan {set ui_status_value {Abort completed. Ready.}}
- }
-}
-
-######################################################################
-##
-## browser
-
-set next_browser_id 0
-
-proc new_browser {commit} {
- global next_browser_id cursor_ptr M1B
- global browser_commit browser_status browser_stack browser_path browser_busy
-
- if {[winfo ismapped .]} {
- set w .browser[incr next_browser_id]
- set tl $w
- toplevel $w
- } else {
- set w {}
- set tl .
- }
- set w_list $w.list.l
- set browser_commit($w_list) $commit
- set browser_status($w_list) {Starting...}
- set browser_stack($w_list) {}
- set browser_path($w_list) $browser_commit($w_list):
- set browser_busy($w_list) 1
-
- label $w.path -textvariable browser_path($w_list) \
- -anchor w \
- -justify left \
- -borderwidth 1 \
- -relief sunken \
- -font font_uibold
- pack $w.path -anchor w -side top -fill x
-
- frame $w.list
- text $w_list -background white -borderwidth 0 \
- -cursor $cursor_ptr \
- -state disabled \
- -wrap none \
- -height 20 \
- -width 70 \
- -xscrollcommand [list $w.list.sbx set] \
- -yscrollcommand [list $w.list.sby set] \
- -font font_ui
- $w_list tag conf in_sel \
- -background [$w_list cget -foreground] \
- -foreground [$w_list cget -background]
- scrollbar $w.list.sbx -orient h -command [list $w_list xview]
- scrollbar $w.list.sby -orient v -command [list $w_list yview]
- pack $w.list.sbx -side bottom -fill x
- pack $w.list.sby -side right -fill y
- pack $w_list -side left -fill both -expand 1
- pack $w.list -side top -fill both -expand 1
-
- label $w.status -textvariable browser_status($w_list) \
- -anchor w \
- -justify left \
- -borderwidth 1 \
- -relief sunken \
- -font font_ui
- pack $w.status -anchor w -side bottom -fill x
-
- bind $w_list <Button-1> "browser_click 0 $w_list @%x,%y;break"
- bind $w_list <Double-Button-1> "browser_click 1 $w_list @%x,%y;break"
- bind $w_list <$M1B-Up> "browser_parent $w_list;break"
- bind $w_list <$M1B-Left> "browser_parent $w_list;break"
- bind $w_list <Up> "browser_move -1 $w_list;break"
- bind $w_list <Down> "browser_move 1 $w_list;break"
- bind $w_list <$M1B-Right> "browser_enter $w_list;break"
- bind $w_list <Return> "browser_enter $w_list;break"
- bind $w_list <Prior> "browser_page -1 $w_list;break"
- bind $w_list <Next> "browser_page 1 $w_list;break"
- bind $w_list <Left> break
- bind $w_list <Right> break
-
- bind $tl <Visibility> "focus $w"
- bind $tl <Destroy> "
- array unset browser_buffer $w_list
- array unset browser_files $w_list
- array unset browser_status $w_list
- array unset browser_stack $w_list
- array unset browser_path $w_list
- array unset browser_commit $w_list
- array unset browser_busy $w_list
- "
- wm title $tl "[appname] ([reponame]): File Browser"
- ls_tree $w_list $browser_commit($w_list) {}
-}
-
-proc browser_move {dir w} {
- global browser_files browser_busy
-
- if {$browser_busy($w)} return
- set lno [lindex [split [$w index in_sel.first] .] 0]
- incr lno $dir
- if {[lindex $browser_files($w) [expr {$lno - 1}]] ne {}} {
- $w tag remove in_sel 0.0 end
- $w tag add in_sel $lno.0 [expr {$lno + 1}].0
- $w see $lno.0
- }
-}
-
-proc browser_page {dir w} {
- global browser_files browser_busy
-
- if {$browser_busy($w)} return
- $w yview scroll $dir pages
- set lno [expr {int(
- [lindex [$w yview] 0]
- * [llength $browser_files($w)]
- + 1)}]
- if {[lindex $browser_files($w) [expr {$lno - 1}]] ne {}} {
- $w tag remove in_sel 0.0 end
- $w tag add in_sel $lno.0 [expr {$lno + 1}].0
- $w see $lno.0
- }
-}
-
-proc browser_parent {w} {
- global browser_files browser_status browser_path
- global browser_stack browser_busy
-
- if {$browser_busy($w)} return
- set info [lindex $browser_files($w) 0]
- if {[lindex $info 0] eq {parent}} {
- set parent [lindex $browser_stack($w) end-1]
- set browser_stack($w) [lrange $browser_stack($w) 0 end-2]
- if {$browser_stack($w) eq {}} {
- regsub {:.*$} $browser_path($w) {:} browser_path($w)
- } else {
- regsub {/[^/]+$} $browser_path($w) {} browser_path($w)
- }
- set browser_status($w) "Loading $browser_path($w)..."
- ls_tree $w [lindex $parent 0] [lindex $parent 1]
- }
-}
-
-proc browser_enter {w} {
- global browser_files browser_status browser_path
- global browser_commit browser_stack browser_busy
-
- if {$browser_busy($w)} return
- set lno [lindex [split [$w index in_sel.first] .] 0]
- set info [lindex $browser_files($w) [expr {$lno - 1}]]
- if {$info ne {}} {
- switch -- [lindex $info 0] {
- parent {
- browser_parent $w
- }
- tree {
- set name [lindex $info 2]
- set escn [escape_path $name]
- set browser_status($w) "Loading $escn..."
- append browser_path($w) $escn
- ls_tree $w [lindex $info 1] $name
- }
- blob {
- set name [lindex $info 2]
- set p {}
- foreach n $browser_stack($w) {
- append p [lindex $n 1]
- }
- append p $name
- show_blame $browser_commit($w) $p
- }
- }
- }
-}
-
-proc browser_click {was_double_click w pos} {
- global browser_files browser_busy
-
- if {$browser_busy($w)} return
- set lno [lindex [split [$w index $pos] .] 0]
- focus $w
-
- if {[lindex $browser_files($w) [expr {$lno - 1}]] ne {}} {
- $w tag remove in_sel 0.0 end
- $w tag add in_sel $lno.0 [expr {$lno + 1}].0
- if {$was_double_click} {
- browser_enter $w
- }
- }
-}
-
-proc ls_tree {w tree_id name} {
- global browser_buffer browser_files browser_stack browser_busy
-
- set browser_buffer($w) {}
- set browser_files($w) {}
- set browser_busy($w) 1
-
- $w conf -state normal
- $w tag remove in_sel 0.0 end
- $w delete 0.0 end
- if {$browser_stack($w) ne {}} {
- $w image create end \
- -align center -padx 5 -pady 1 \
- -name icon0 \
- -image file_uplevel
- $w insert end {[Up To Parent]}
- lappend browser_files($w) parent
- }
- lappend browser_stack($w) [list $tree_id $name]
- $w conf -state disabled
-
- set cmd [list git ls-tree -z $tree_id]
- set fd [open "| $cmd" r]
- fconfigure $fd -blocking 0 -translation binary -encoding binary
- fileevent $fd readable [list read_ls_tree $fd $w]
-}
-
-proc read_ls_tree {fd w} {
- global browser_buffer browser_files browser_status browser_busy
-
- if {![winfo exists $w]} {
- catch {close $fd}
- return
- }
-
- append browser_buffer($w) [read $fd]
- set pck [split $browser_buffer($w) "\0"]
- set browser_buffer($w) [lindex $pck end]
-
- set n [llength $browser_files($w)]
- $w conf -state normal
- foreach p [lrange $pck 0 end-1] {
- set info [split $p "\t"]
- set path [lindex $info 1]
- set info [split [lindex $info 0] { }]
- set type [lindex $info 1]
- set object [lindex $info 2]
-
- switch -- $type {
- blob {
- set image file_mod
- }
- tree {
- set image file_dir
- append path /
- }
- default {
- set image file_question
- }
- }
-
- if {$n > 0} {$w insert end "\n"}
- $w image create end \
- -align center -padx 5 -pady 1 \
- -name icon[incr n] \
- -image $image
- $w insert end [escape_path $path]
- lappend browser_files($w) [list $type $object $path]
- }
- $w conf -state disabled
-
- if {[eof $fd]} {
- close $fd
- set browser_status($w) Ready.
- set browser_busy($w) 0
- array unset browser_buffer $w
- if {$n > 0} {
- $w tag add in_sel 1.0 2.0
- focus -force $w
- }
- }
-}
-
-proc show_blame {commit path} {
- global next_browser_id blame_status blame_data
-
- if {[winfo ismapped .]} {
- set w .browser[incr next_browser_id]
- set tl $w
- toplevel $w
- } else {
- set w {}
- set tl .
- }
- set blame_status($w) {Loading current file content...}
-
- label $w.path -text "$commit:$path" \
- -anchor w \
- -justify left \
- -borderwidth 1 \
- -relief sunken \
- -font font_uibold
- pack $w.path -side top -fill x
-
- frame $w.out
- text $w.out.loaded_t \
- -background white -borderwidth 0 \
- -state disabled \
- -wrap none \
- -height 40 \
- -width 1 \
- -font font_diff
- $w.out.loaded_t tag conf annotated -background grey
-
- text $w.out.linenumber_t \
- -background white -borderwidth 0 \
- -state disabled \
- -wrap none \
- -height 40 \
- -width 5 \
- -font font_diff
- $w.out.linenumber_t tag conf linenumber -justify right
-
- text $w.out.file_t \
- -background white -borderwidth 0 \
- -state disabled \
- -wrap none \
- -height 40 \
- -width 80 \
- -xscrollcommand [list $w.out.sbx set] \
- -font font_diff
-
- scrollbar $w.out.sbx -orient h -command [list $w.out.file_t xview]
- scrollbar $w.out.sby -orient v \
- -command [list scrollbar2many [list \
- $w.out.loaded_t \
- $w.out.linenumber_t \
- $w.out.file_t \
- ] yview]
- grid \
- $w.out.linenumber_t \
- $w.out.loaded_t \
- $w.out.file_t \
- $w.out.sby \
- -sticky nsew
- grid conf $w.out.sbx -column 2 -sticky we
- grid columnconfigure $w.out 2 -weight 1
- grid rowconfigure $w.out 0 -weight 1
- pack $w.out -fill both -expand 1
-
- label $w.status -textvariable blame_status($w) \
- -anchor w \
- -justify left \
- -borderwidth 1 \
- -relief sunken \
- -font font_ui
- pack $w.status -side bottom -fill x
-
- frame $w.cm
- text $w.cm.t \
- -background white -borderwidth 0 \
- -state disabled \
- -wrap none \
- -height 10 \
- -width 80 \
- -xscrollcommand [list $w.cm.sbx set] \
- -yscrollcommand [list $w.cm.sby set] \
- -font font_diff
- scrollbar $w.cm.sbx -orient h -command [list $w.cm.t xview]
- scrollbar $w.cm.sby -orient v -command [list $w.cm.t yview]
- pack $w.cm.sby -side right -fill y
- pack $w.cm.sbx -side bottom -fill x
- pack $w.cm.t -expand 1 -fill both
- pack $w.cm -side bottom -fill x
-
- menu $w.ctxm -tearoff 0
- $w.ctxm add command -label "Copy Commit" \
- -font font_ui \
- -command "blame_copycommit $w \$cursorW @\$cursorX,\$cursorY"
-
- foreach i [list \
- $w.out.loaded_t \
- $w.out.linenumber_t \
- $w.out.file_t] {
- $i tag conf in_sel \
- -background [$i cget -foreground] \
- -foreground [$i cget -background]
- $i conf -yscrollcommand \
- [list many2scrollbar [list \
- $w.out.loaded_t \
- $w.out.linenumber_t \
- $w.out.file_t \
- ] yview $w.out.sby]
- bind $i <Button-1> "
- blame_click {$w} \\
- $w.cm.t \\
- $w.out.linenumber_t \\
- $w.out.file_t \\
- $i @%x,%y
- focus $i
- "
- bind_button3 $i "
- set cursorX %x
- set cursorY %y
- set cursorW %W
- tk_popup $w.ctxm %X %Y
- "
- }
-
- bind $w.cm.t <Button-1> "focus $w.cm.t"
- bind $tl <Visibility> "focus $tl"
- bind $tl <Destroy> "
- array unset blame_status {$w}
- array unset blame_data $w,*
- "
- wm title $tl "[appname] ([reponame]): File Viewer"
-
- set blame_data($w,commit_count) 0
- set blame_data($w,commit_list) {}
- set blame_data($w,total_lines) 0
- set blame_data($w,blame_lines) 0
- set blame_data($w,highlight_commit) {}
- set blame_data($w,highlight_line) -1
-
- set cmd [list git cat-file blob "$commit:$path"]
- set fd [open "| $cmd" r]
- fconfigure $fd -blocking 0 -translation lf -encoding binary
- fileevent $fd readable [list read_blame_catfile \
- $fd $w $commit $path \
- $w.cm.t $w.out.loaded_t $w.out.linenumber_t $w.out.file_t]
-}
-
-proc read_blame_catfile {fd w commit path w_cmit w_load w_line w_file} {
- global blame_status blame_data
-
- if {![winfo exists $w_file]} {
- catch {close $fd}
- return
- }
-
- set n $blame_data($w,total_lines)
- $w_load conf -state normal
- $w_line conf -state normal
- $w_file conf -state normal
- while {[gets $fd line] >= 0} {
- regsub "\r\$" $line {} line
- incr n
- $w_load insert end "\n"
- $w_line insert end "$n\n" linenumber
- $w_file insert end "$line\n"
- }
- $w_load conf -state disabled
- $w_line conf -state disabled
- $w_file conf -state disabled
- set blame_data($w,total_lines) $n
-
- if {[eof $fd]} {
- close $fd
- blame_incremental_status $w
- set cmd [list git blame -M -C --incremental]
- lappend cmd $commit -- $path
- set fd [open "| $cmd" r]
- fconfigure $fd -blocking 0 -translation lf -encoding binary
- fileevent $fd readable [list read_blame_incremental $fd $w \
- $w_load $w_cmit $w_line $w_file]
- }
-}
-
-proc read_blame_incremental {fd w w_load w_cmit w_line w_file} {
- global blame_status blame_data
-
- if {![winfo exists $w_file]} {
- catch {close $fd}
- return
- }
-
- while {[gets $fd line] >= 0} {
- if {[regexp {^([a-z0-9]{40}) (\d+) (\d+) (\d+)$} $line line \
- cmit original_line final_line line_count]} {
- set blame_data($w,commit) $cmit
- set blame_data($w,original_line) $original_line
- set blame_data($w,final_line) $final_line
- set blame_data($w,line_count) $line_count
-
- if {[catch {set g $blame_data($w,$cmit,order)}]} {
- $w_line tag conf g$cmit
- $w_file tag conf g$cmit
- $w_line tag raise in_sel
- $w_file tag raise in_sel
- $w_file tag raise sel
- set blame_data($w,$cmit,order) $blame_data($w,commit_count)
- incr blame_data($w,commit_count)
- lappend blame_data($w,commit_list) $cmit
- }
- } elseif {[string match {filename *} $line]} {
- set file [string range $line 9 end]
- set n $blame_data($w,line_count)
- set lno $blame_data($w,final_line)
- set cmit $blame_data($w,commit)
-
- while {$n > 0} {
- if {[catch {set g g$blame_data($w,line$lno,commit)}]} {
- $w_load tag add annotated $lno.0 "$lno.0 lineend + 1c"
- } else {
- $w_line tag remove g$g $lno.0 "$lno.0 lineend + 1c"
- $w_file tag remove g$g $lno.0 "$lno.0 lineend + 1c"
- }
-
- set blame_data($w,line$lno,commit) $cmit
- set blame_data($w,line$lno,file) $file
- $w_line tag add g$cmit $lno.0 "$lno.0 lineend + 1c"
- $w_file tag add g$cmit $lno.0 "$lno.0 lineend + 1c"
-
- if {$blame_data($w,highlight_line) == -1} {
- if {[lindex [$w_file yview] 0] == 0} {
- $w_file see $lno.0
- blame_showcommit $w $w_cmit $w_line $w_file $lno
- }
- } elseif {$blame_data($w,highlight_line) == $lno} {
- blame_showcommit $w $w_cmit $w_line $w_file $lno
- }
-
- incr n -1
- incr lno
- incr blame_data($w,blame_lines)
- }
-
- set hc $blame_data($w,highlight_commit)
- if {$hc ne {}
- && [expr {$blame_data($w,$hc,order) + 1}]
- == $blame_data($w,$cmit,order)} {
- blame_showcommit $w $w_cmit $w_line $w_file \
- $blame_data($w,highlight_line)
- }
- } elseif {[regexp {^([a-z-]+) (.*)$} $line line header data]} {
- set blame_data($w,$blame_data($w,commit),$header) $data
- }
- }
-
- if {[eof $fd]} {
- close $fd
- set blame_status($w) {Annotation complete.}
- } else {
- blame_incremental_status $w
- }
-}
-
-proc blame_incremental_status {w} {
- global blame_status blame_data
-
- set blame_status($w) [format \
- "Loading annotations... %i of %i lines annotated (%2i%%)" \
- $blame_data($w,blame_lines) \
- $blame_data($w,total_lines) \
- [expr {100 * $blame_data($w,blame_lines)
- / $blame_data($w,total_lines)}]]
-}
-
-proc blame_click {w w_cmit w_line w_file cur_w pos} {
- set lno [lindex [split [$cur_w index $pos] .] 0]
- if {$lno eq {}} return
-
- $w_line tag remove in_sel 0.0 end
- $w_file tag remove in_sel 0.0 end
- $w_line tag add in_sel $lno.0 "$lno.0 + 1 line"
- $w_file tag add in_sel $lno.0 "$lno.0 + 1 line"
-
- blame_showcommit $w $w_cmit $w_line $w_file $lno
-}
-
-set blame_colors {
- #ff4040
- #ff40ff
- #4040ff
-}
-
-proc blame_showcommit {w w_cmit w_line w_file lno} {
- global blame_colors blame_data repo_config
-
- set cmit $blame_data($w,highlight_commit)
- if {$cmit ne {}} {
- set idx $blame_data($w,$cmit,order)
- set i 0
- foreach c $blame_colors {
- set h [lindex $blame_data($w,commit_list) [expr {$idx - 1 + $i}]]
- $w_line tag conf g$h -background white
- $w_file tag conf g$h -background white
- incr i
- }
- }
-
- $w_cmit conf -state normal
- $w_cmit delete 0.0 end
- if {[catch {set cmit $blame_data($w,line$lno,commit)}]} {
- set cmit {}
- $w_cmit insert end "Loading annotation..."
- } else {
- set idx $blame_data($w,$cmit,order)
- set i 0
- foreach c $blame_colors {
- set h [lindex $blame_data($w,commit_list) [expr {$idx - 1 + $i}]]
- $w_line tag conf g$h -background $c
- $w_file tag conf g$h -background $c
- incr i
- }
-
- if {[catch {set msg $blame_data($w,$cmit,message)}]} {
- set msg {}
- catch {
- set fd [open "| git cat-file commit $cmit" r]
- fconfigure $fd -encoding binary -translation lf
- if {[catch {set enc $repo_config(i18n.commitencoding)}]} {
- set enc utf-8
- }
- while {[gets $fd line] > 0} {
- if {[string match {encoding *} $line]} {
- set enc [string tolower [string range $line 9 end]]
- }
- }
- fconfigure $fd -encoding $enc
- set msg [string trim [read $fd]]
- close $fd
- }
- set blame_data($w,$cmit,message) $msg
- }
-
- set author_name {}
- set author_email {}
- set author_time {}
- catch {set author_name $blame_data($w,$cmit,author)}
- catch {set author_email $blame_data($w,$cmit,author-mail)}
- catch {set author_time [clock format $blame_data($w,$cmit,author-time)]}
-
- set committer_name {}
- set committer_email {}
- set committer_time {}
- catch {set committer_name $blame_data($w,$cmit,committer)}
- catch {set committer_email $blame_data($w,$cmit,committer-mail)}
- catch {set committer_time [clock format $blame_data($w,$cmit,committer-time)]}
-
- $w_cmit insert end "commit $cmit\n"
- $w_cmit insert end "Author: $author_name $author_email $author_time\n"
- $w_cmit insert end "Committer: $committer_name $committer_email $committer_time\n"
- $w_cmit insert end "Original File: [escape_path $blame_data($w,line$lno,file)]\n"
- $w_cmit insert end "\n"
- $w_cmit insert end $msg
- }
- $w_cmit conf -state disabled
-
- set blame_data($w,highlight_line) $lno
- set blame_data($w,highlight_commit) $cmit
-}
-
-proc blame_copycommit {w i pos} {
- global blame_data
- set lno [lindex [split [$i index $pos] .] 0]
- if {![catch {set commit $blame_data($w,line$lno,commit)}]} {
- clipboard clear
- clipboard append \
- -format STRING \
- -type STRING \
- -- $commit
- }