1# git-gui remote branch deleting support
2# Copyright (C) 2007 Shawn Pearce
3class remote_branch_delete {
5field w
7field head_m
8field urltype {url}
10field remote {}
11field url {}
12field checktype {head}
14field check_head {}
15field status {}
17field idle_id {}
18field full_list {}
19field head_list {}
20field active_ls {}
21field head_cache
22field full_cache
23field cached
24constructor dialog {} {
26 global all_remotes M1B
27 make_toplevel top w
29 wm title $top "[appname] ([reponame]): Delete Remote Branch"
30 if {$top ne {.}} {
31 wm geometry $top "+[winfo rootx .]+[winfo rooty .]"
32 }
33 label $w.header -text {Delete Remote Branch} -font font_uibold
35 pack $w.header -side top -fill x
36 frame $w.buttons
38 button $w.buttons.delete -text Delete \
39 -default active \
40 -command [cb _delete]
41 pack $w.buttons.delete -side right
42 button $w.buttons.cancel -text {Cancel} \
43 -command [list destroy $w]
44 pack $w.buttons.cancel -side right -padx 5
45 pack $w.buttons -side bottom -fill x -pady 10 -padx 10
46 labelframe $w.dest -text {From Repository}
48 if {$all_remotes ne {}} {
49 radiobutton $w.dest.remote_r \
50 -text {Remote:} \
51 -value remote \
52 -variable @urltype
53 eval tk_optionMenu $w.dest.remote_m @remote $all_remotes
54 grid $w.dest.remote_r $w.dest.remote_m -sticky w
55 if {[lsearch -sorted -exact $all_remotes origin] != -1} {
56 set remote origin
57 } else {
58 set remote [lindex $all_remotes 0]
59 }
60 set urltype remote
61 trace add variable @remote write [cb _write_remote]
62 } else {
63 set urltype url
64 }
65 radiobutton $w.dest.url_r \
66 -text {Arbitrary URL:} \
67 -value url \
68 -variable @urltype
69 entry $w.dest.url_t \
70 -borderwidth 1 \
71 -relief sunken \
72 -width 50 \
73 -textvariable @url \
74 -validate key \
75 -validatecommand {
76 if {%d == 1 && [regexp {\s} %S]} {return 0}
77 return 1
78 }
79 trace add variable @url write [cb _write_url]
80 grid $w.dest.url_r $w.dest.url_t -sticky we -padx {0 5}
81 grid columnconfigure $w.dest 1 -weight 1
82 pack $w.dest -anchor nw -fill x -pady 5 -padx 5
83 labelframe $w.heads -text {Branches}
85 listbox $w.heads.l \
86 -height 10 \
87 -width 70 \
88 -listvariable @head_list \
89 -selectmode extended \
90 -yscrollcommand [list $w.heads.sby set]
91 scrollbar $w.heads.sby -command [list $w.heads.l yview]
92 frame $w.heads.footer
94 label $w.heads.footer.status \
95 -textvariable @status \
96 -anchor w \
97 -justify left
98 button $w.heads.footer.rescan \
99 -text {Rescan} \
100 -command [cb _rescan]
101 pack $w.heads.footer.status -side left -fill x -expand 1
102 pack $w.heads.footer.rescan -side right
103 pack $w.heads.footer -side bottom -fill x -expand 1
105 pack $w.heads.sby -side right -fill y
106 pack $w.heads.l -side left -fill both -expand 1
107 pack $w.heads -fill both -expand 1 -pady 5 -padx 5
108 labelframe $w.validate -text {Delete Only If}
110 radiobutton $w.validate.head_r \
111 -text {Merged Into:} \
112 -value head \
113 -variable @checktype
114 set head_m [tk_optionMenu $w.validate.head_m @check_head {}]
115 trace add variable @head_list write [cb _write_head_list]
116 trace add variable @check_head write [cb _write_check_head]
117 grid $w.validate.head_r $w.validate.head_m -sticky w
118 radiobutton $w.validate.always_r \
119 -text {Always (Do not perform merge checks)} \
120 -value always \
121 -variable @checktype
122 grid $w.validate.always_r -columnspan 2 -sticky w
123 grid columnconfigure $w.validate 1 -weight 1
124 pack $w.validate -anchor nw -fill x -pady 5 -padx 5
125 trace add variable @urltype write [cb _write_urltype]
127 _rescan $this
128 bind $w <Key-F5> [cb _rescan]
130 bind $w <$M1B-Key-r> [cb _rescan]
131 bind $w <$M1B-Key-R> [cb _rescan]
132 bind $w <Key-Return> [cb _delete]
133 bind $w <Key-Escape> [list destroy $w]
134 return $w
135}
136method _delete {} {
138 switch $urltype {
139 remote {set uri $remote}
140 url {set uri $url}
141 }
142 set cache $urltype:$uri
144 set crev {}
145 if {$checktype eq {head}} {
146 if {$check_head eq {}} {
147 tk_messageBox \
148 -icon error \
149 -type ok \
150 -title [wm title $w] \
151 -parent $w \
152 -message "A branch is required for 'Merged Into'."
153 return
154 }
155 set crev $full_cache("$cache\nrefs/heads/$check_head")
156 }
157 set not_merged [list]
159 set need_fetch 0
160 set have_selection 0
161 set push_cmd [list git push]
162 lappend push_cmd -v
163 lappend push_cmd $uri
164 foreach i [$w.heads.l curselection] {
166 set ref [lindex $full_list $i]
167 if {$crev ne {}} {
168 set obj $full_cache("$cache\n$ref")
169 if {[catch {set m [git merge-base $obj $crev]}]} {
170 set need_fetch 1
171 set m {}
172 }
173 if {$obj ne $m} {
174 lappend not_merged [lindex $head_list $i]
175 continue
176 }
177 }
178 lappend push_cmd :$ref
180 set have_selection 1
181 }
182 if {$not_merged ne {}} {
184 set msg "The following branches are not completely merged into $check_head:
185 - [join $not_merged "\n - "]"
187 if {$need_fetch} {
189 append msg "
190One or more of the merge tests failed because you have not fetched the necessary commits. Try fetching from $uri first."
192 }
193 tk_messageBox \
195 -icon info \
196 -type ok \
197 -title [wm title $w] \
198 -parent $w \
199 -message $msg
200 if {!$have_selection} return
201 }
202 if {!$have_selection} {
204 tk_messageBox \
205 -icon error \
206 -type ok \
207 -title [wm title $w] \
208 -parent $w \
209 -message "Please select one or more branches to delete."
210 return
211 }
212 if {[tk_messageBox \
214 -icon warning \
215 -type yesno \
216 -title [wm title $w] \
217 -parent $w \
218 -message {Recovering deleted branches is difficult.
219Delete the selected branches?}] ne yes} {
221 return
222 }
223 destroy $w
225 set cons [console::new \
227 "push $uri" \
228 "Deleting branches from $uri"]
229 console::exec $cons $push_cmd
230}
231method _rescan {{force 1}} {
233 switch $urltype {
234 remote {set uri $remote}
235 url {set uri $url}
236 }
237 if {$force} {
239 unset -nocomplain cached($urltype:$uri)
240 }
241 if {$idle_id ne {}} {
243 after cancel $idle_id
244 set idle_id {}
245 }
246 _load $this $urltype:$uri $uri
248}
249method _write_remote {args} { set urltype remote }
251method _write_url {args} { set urltype url }
252method _write_check_head {args} { set checktype head }
253method _write_head_list {args} {
255 $head_m delete 0 end
256 foreach abr $head_list {
257 $head_m insert end radiobutton \
258 -label $abr \
259 -value $abr \
260 -variable @check_head
261 }
262 if {[lsearch -exact -sorted $head_list $check_head] < 0} {
263 set check_head {}
264 }
265}
266method _write_urltype {args} {
268 if {$urltype eq {url}} {
269 if {$idle_id ne {}} {
270 after cancel $idle_id
271 }
272 _load $this none: {}
273 set idle_id [after 1000 [cb _rescan 0]]
274 } else {
275 _rescan $this 0
276 }
277}
278method _load {cache uri} {
280 if {$active_ls ne {}} {
281 catch {close $active_ls}
282 }
283 if {$uri eq {}} {
285 $w.heads.l conf -state disabled
286 set head_list [list]
287 set full_list [list]
288 set status {No repository selected.}
289 return
290 }
291 if {[catch {set x $cached($cache)}]} {
293 set status "Scanning $uri..."
294 $w.heads.l conf -state disabled
295 set head_list [list]
296 set full_list [list]
297 set head_cache($cache) [list]
298 set full_cache($cache) [list]
299 set active_ls [open "| [list git ls-remote $uri]" r]
300 fconfigure $active_ls \
301 -blocking 0 \
302 -translation lf \
303 -encoding utf-8
304 fileevent $active_ls readable [cb _read $cache $active_ls]
305 } else {
306 set status {}
307 set full_list $full_cache($cache)
308 set head_list $head_cache($cache)
309 $w.heads.l conf -state normal
310 }
311}
312method _read {cache fd} {
314 if {$fd ne $active_ls} {
315 catch {close $fd}
316 return
317 }
318 while {[gets $fd line] >= 0} {
320 if {[string match {*^{}} $line]} continue
321 if {[regexp {^([0-9a-f]{40}) (.*)$} $line _junk obj ref]} {
322 if {[regsub ^refs/heads/ $ref {} abr]} {
323 lappend head_list $abr
324 lappend head_cache($cache) $abr
325 lappend full_list $ref
326 lappend full_cache($cache) $ref
327 set full_cache("$cache\n$ref") $obj
328 }
329 }
330 }
331 if {[eof $fd]} {
333 if {[catch {close $fd} err]} {
334 set status $err
335 set head_list [list]
336 set full_list [list]
337 } else {
338 set status {}
339 set cached($cache) 1
340 $w.heads.l conf -state normal
341 }
342 }
343} ifdeleted {
344 catch {close $fd}
345}
346}