summaryrefslogtreecommitdiff
path: root/lib/remote_branch_delete.tcl
blob: 5ba9fcadd17f315a4a47220f91f81ba964d64b08 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
# git-gui remote branch deleting support
# Copyright (C) 2007 Shawn Pearce

class remote_branch_delete {

field w
field head_m

field urltype   {url}
field remote    {}
field url       {}

field checktype  {head}
field check_head {}

field status    {}
field idle_id   {}
field full_list {}
field head_list {}
field active_ls {}
field head_cache
field full_cache
field cached

constructor dialog {} {
	global all_remotes M1B use_ttk NS

	make_dialog top w
	wm title $top [mc "%s (%s): Delete Branch Remotely" [appname] [reponame]]
	if {$top ne {.}} {
		wm geometry $top "+[winfo rootx .]+[winfo rooty .]"
	}

	${NS}::label $w.header -text [mc "Delete Branch Remotely"] \
		-font font_uibold -anchor center
	pack $w.header -side top -fill x

	${NS}::frame $w.buttons
	${NS}::button $w.buttons.delete -text [mc Delete] \
		-default active \
		-command [cb _delete]
	pack $w.buttons.delete -side right
	${NS}::button $w.buttons.cancel -text [mc "Cancel"] \
		-command [list destroy $w]
	pack $w.buttons.cancel -side right -padx 5
	pack $w.buttons -side bottom -fill x -pady 10 -padx 10

	${NS}::labelframe $w.dest -text [mc "From Repository"]
	if {$all_remotes ne {}} {
		${NS}::radiobutton $w.dest.remote_r \
			-text [mc "Remote:"] \
			-value remote \
			-variable @urltype
		if {$use_ttk} {
			ttk::combobox $w.dest.remote_m -textvariable @remote \
				-values $all_remotes -state readonly
		} else {
			eval tk_optionMenu $w.dest.remote_m @remote $all_remotes
		}
		grid $w.dest.remote_r $w.dest.remote_m -sticky w
		if {[lsearch -sorted -exact $all_remotes origin] != -1} {
			set remote origin
		} else {
			set remote [lindex $all_remotes 0]
		}
		set urltype remote
		trace add variable @remote write [cb _write_remote]
	} else {
		set urltype url
	}
	${NS}::radiobutton $w.dest.url_r \
		-text [mc "Arbitrary Location:"] \
		-value url \
		-variable @urltype
	${NS}::entry $w.dest.url_t \
		-width 50 \
		-textvariable @url \
		-validate key \
		-validatecommand {
			if {%d == 1 && [regexp {\s} %S]} {return 0}
			return 1
		}
	trace add variable @url write [cb _write_url]
	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

	${NS}::labelframe $w.heads -text [mc "Branches"]
	slistbox $w.heads.l \
		-height 10 \
		-width 70 \
		-listvariable @head_list \
		-selectmode extended

	${NS}::frame $w.heads.footer
	${NS}::label $w.heads.footer.status \
		-textvariable @status \
		-anchor w \
		-justify left
	${NS}::button $w.heads.footer.rescan \
		-text [mc "Rescan"] \
		-command [cb _rescan]
	pack $w.heads.footer.status -side left -fill x
	pack $w.heads.footer.rescan -side right

	pack $w.heads.footer -side bottom -fill x
	pack $w.heads.l -side left -fill both -expand 1
	pack $w.heads -fill both -expand 1 -pady 5 -padx 5

	${NS}::labelframe $w.validate -text [mc "Delete Only If"]
	${NS}::radiobutton $w.validate.head_r \
		-text [mc "Merged Into:"] \
		-value head \
		-variable @checktype
	set head_m [tk_optionMenu $w.validate.head_m @check_head {}]
	trace add variable @head_list write [cb _write_head_list]
	trace add variable @check_head write [cb _write_check_head]
	grid $w.validate.head_r $w.validate.head_m -sticky w
	${NS}::radiobutton $w.validate.always_r \
		-text [mc "Always (Do not perform merge checks)"] \
		-value always \
		-variable @checktype
	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

	trace add variable @urltype write [cb _write_urltype]
	_rescan $this

	bind $w <Key-F5>     [cb _rescan]
	bind $w <$M1B-Key-r> [cb _rescan]
	bind $w <$M1B-Key-R> [cb _rescan]
	bind $w <Key-Return> [cb _delete]
	bind $w <Key-Escape> [list destroy $w]
	return $w
}

method _delete {} {
	switch $urltype {
	remote {set uri $remote}
	url    {set uri $url}
	}

	set cache $urltype:$uri
	set crev {}
	if {$checktype eq {head}} {
		if {$check_head eq {}} {
			tk_messageBox \
				-icon error \
				-type ok \
				-title [wm title $w] \
				-parent $w \
				-message [mc "A branch is required for 'Merged Into'."]
			return
		}
		set crev $full_cache("$cache\nrefs/heads/$check_head")
	}

	set not_merged [list]
	set need_fetch 0
	set have_selection 0
	set push_cmd [list git push]
	lappend push_cmd -v
	lappend push_cmd $uri

	foreach i [$w.heads.l curselection] {
		set ref [lindex $full_list $i]
		if {$crev ne {}} {
			set obj $full_cache("$cache\n$ref")
			if {[catch {set m [git merge-base $obj $crev]}]} {
				set need_fetch 1
				set m {}
			}
			if {$obj ne $m} {
				lappend not_merged [lindex $head_list $i]
				continue
			}
		}

		lappend push_cmd :$ref
		set have_selection 1
	}

	if {$not_merged ne {}} {
		set msg [mc "The following branches are not completely merged into %s:

 - %s" $check_head [join $not_merged "\n - "]]

		if {$need_fetch} {
			append msg "\n\n" [mc "One or more of the merge tests failed because you have not fetched the necessary commits.  Try fetching from %s first." $uri]
		}

		tk_messageBox \
			-icon info \
			-type ok \
			-title [wm title $w] \
			-parent $w \
			-message $msg
		if {!$have_selection} return
	}

	if {!$have_selection} {
		tk_messageBox \
			-icon error \
			-type ok \
			-title [wm title $w] \
			-parent $w \
			-message [mc "Please select one or more branches to delete."]
		return
	}

	if {$checktype ne {head}} {
		if {[tk_messageBox \
			-icon warning \
			-type yesno \
			-title [wm title $w] \
			-parent $w \
			-message [mc "Recovering deleted branches is difficult.\n\nDelete the selected branches?"]] ne yes} {
			return
		}
	}

	destroy $w

	set cons [console::new \
		"push $uri" \
		[mc "Deleting branches from %s" $uri]]
	console::exec $cons $push_cmd
}

method _rescan {{force 1}} {
	switch $urltype {
	remote {set uri $remote}
	url    {set uri $url}
	}

	if {$force} {
		unset -nocomplain cached($urltype:$uri)
	}

	if {$idle_id ne {}} {
		after cancel $idle_id
		set idle_id {}
	}

	_load $this $urltype:$uri $uri
}

method _write_remote     {args} { set urltype remote }
method _write_url        {args} { set urltype url    }
method _write_check_head {args} { set checktype head }

method _write_head_list {args} {
	global current_branch _last_merged_branch

	$head_m delete 0 end
	foreach abr $head_list {
		$head_m insert end radiobutton \
			-label $abr \
			-value $abr \
			-variable @check_head
	}
	if {[lsearch -exact -sorted $head_list $check_head] < 0} {
		if {[lsearch -exact -sorted $head_list $current_branch] < 0} {
			set check_head {}
		} else {
			set check_head $current_branch
		}
	}
	set lmb [lsearch -exact -sorted $head_list $_last_merged_branch]
	if {$lmb >= 0} {
		$w.heads.l conf -state normal
		$w.heads.l select set $lmb
		$w.heads.l yview $lmb
		$w.heads.l conf -state disabled
	}
}

method _write_urltype {args} {
	if {$urltype eq {url}} {
		if {$idle_id ne {}} {
			after cancel $idle_id
		}
		_load $this none: {}
		set idle_id [after 1000 [cb _rescan 0]]
	} else {
		_rescan $this 0
	}
}

method _load {cache uri} {
	if {$active_ls ne {}} {
		catch {close $active_ls}
	}

	if {$uri eq {}} {
		$w.heads.l conf -state disabled
		set head_list [list]
		set full_list [list]
		set status [mc "No repository selected."]
		return
	}

	if {[catch {set x $cached($cache)}]} {
		set status [mc "Scanning %s..." $uri]
		$w.heads.l conf -state disabled
		set head_list [list]
		set full_list [list]
		set head_cache($cache) [list]
		set full_cache($cache) [list]
		set active_ls [git_read ls-remote $uri]
		fconfigure $active_ls \
			-blocking 0 \
			-translation lf \
			-encoding utf-8
		fileevent $active_ls readable [cb _read $cache $active_ls]
	} else {
		set status {}
		set full_list $full_cache($cache)
		set head_list $head_cache($cache)
		$w.heads.l conf -state normal
	}
}

method _read {cache fd} {
	if {$fd ne $active_ls} {
		catch {close $fd}
		return
	}

	while {[gets $fd line] >= 0} {
		if {[string match {*^{}} $line]} continue
		if {[regexp {^([0-9a-f]{40})	(.*)$} $line _junk obj ref]} {
			if {[regsub ^refs/heads/ $ref {} abr]} {
				lappend head_list $abr
				lappend head_cache($cache) $abr
				lappend full_list $ref
				lappend full_cache($cache) $ref
				set full_cache("$cache\n$ref") $obj
			}
		}
	}

	if {[eof $fd]} {
		if {[catch {close $fd} err]} {
			set status $err
			set head_list [list]
			set full_list [list]
		} else {
			set status {}
			set cached($cache) 1
			$w.heads.l conf -state normal
		}
	}
} ifdeleted {
	catch {close $fd}
}

}