1# git-gui Git repository chooser
2# Copyright (C) 2007 Shawn Pearce
3
4class choose_repository {
5
6field top
7field w
8field w_body      ; # Widget holding the center content
9field w_next      ; # Next button
10field w_quit      ; # Quit button
11field o_cons      ; # Console object (if active)
12
13# Status mega-widget instance during _do_clone2 (used by _copy_files and
14# _link_files). Widget is destroyed before _do_clone2 calls
15# _do_clone_checkout
16field o_status
17
18# Operation displayed by status mega-widget during _do_clone_checkout =>
19# _readtree_wait => _postcheckout_wait => _do_clone_submodules =>
20# _do_validate_submodule_cloning. The status mega-widget is a different
21# instance than that stored in $o_status in earlier operations.
22field o_status_op
23
24field w_types     ; # List of type buttons in clone
25field w_recentlist ; # Listbox containing recent repositories
26field w_localpath  ; # Entry widget bound to local_path
27
28field done              0 ; # Finished picking the repository?
29field local_path       {} ; # Where this repository is locally
30field origin_url       {} ; # Where we are cloning from
31field origin_name  origin ; # What we shall call 'origin'
32field clone_type hardlink ; # Type of clone to construct
33field recursive      true ; # Recursive cloning flag
34field readtree_err        ; # Error output from read-tree (if any)
35field sorted_recent       ; # recent repositories (sorted)
36
37constructor pick {} {
38	global M1T M1B use_ttk NS
39
40	if {[set maxrecent [get_config gui.maxrecentrepo]] eq {}} {
41		set maxrecent 10
42	}
43
44	make_dialog top w
45	wm title $top [mc "Git Gui"]
46
47	if {$top eq {.}} {
48		menu $w.mbar -tearoff 0
49		$top configure -menu $w.mbar
50
51		set m_repo $w.mbar.repository
52		$w.mbar add cascade \
53			-label [mc Repository] \
54			-menu $m_repo
55		menu $m_repo
56
57		if {[is_MacOSX]} {
58			$w.mbar add cascade -label Apple -menu .mbar.apple
59			menu $w.mbar.apple
60			$w.mbar.apple add command \
61				-label [mc "About %s" [appname]] \
62				-command do_about
63			$w.mbar.apple add command \
64				-label [mc "Show SSH Key"] \
65				-command do_ssh_key
66		} else {
67			$w.mbar add cascade -label [mc Help] -menu $w.mbar.help
68			menu $w.mbar.help
69			$w.mbar.help add command \
70				-label [mc "About %s" [appname]] \
71				-command do_about
72			$w.mbar.help add command \
73				-label [mc "Show SSH Key"] \
74				-command do_ssh_key
75		}
76
77		wm protocol $top WM_DELETE_WINDOW exit
78		bind $top <$M1B-q> exit
79		bind $top <$M1B-Q> exit
80		bind $top <Key-Escape> exit
81	} else {
82		wm geometry $top "+[winfo rootx .]+[winfo rooty .]"
83		bind $top <Key-Escape> [list destroy $top]
84		set m_repo {}
85	}
86
87	pack [git_logo $w.git_logo] -side left -fill y -padx 10 -pady 10
88
89	set w_body $w.body
90	set opts $w_body.options
91	${NS}::frame $w_body
92	text $opts \
93		-cursor $::cursor_ptr \
94		-relief flat \
95		-background [get_bg_color $w_body] \
96		-wrap none \
97		-spacing1 5 \
98		-width 50 \
99		-height 3
100	pack $opts -anchor w -fill x
101
102	$opts tag conf link_new -foreground blue -underline 1
103	$opts tag bind link_new <1> [cb _next new]
104	$opts insert end [mc "Create New Repository"] link_new
105	$opts insert end "\n"
106	if {$m_repo ne {}} {
107		$m_repo add command \
108			-command [cb _next new] \
109			-accelerator $M1T-N \
110			-label [mc "New..."]
111		bind $top <$M1B-n> [cb _next new]
112		bind $top <$M1B-N> [cb _next new]
113	}
114
115	$opts tag conf link_clone -foreground blue -underline 1
116	$opts tag bind link_clone <1> [cb _next clone]
117	$opts insert end [mc "Clone Existing Repository"] link_clone
118	$opts insert end "\n"
119	if {$m_repo ne {}} {
120		if {[tk windowingsystem] eq "win32"} {
121			set key L
122		} else {
123			set key C
124		}
125		$m_repo add command \
126			-command [cb _next clone] \
127			-accelerator $M1T-$key \
128			-label [mc "Clone..."]
129		bind $top <$M1B-[string tolower $key]> [cb _next clone]
130		bind $top <$M1B-[string toupper $key]> [cb _next clone]
131	}
132
133	$opts tag conf link_open -foreground blue -underline 1
134	$opts tag bind link_open <1> [cb _next open]
135	$opts insert end [mc "Open Existing Repository"] link_open
136	$opts insert end "\n"
137	if {$m_repo ne {}} {
138		$m_repo add command \
139			-command [cb _next open] \
140			-accelerator $M1T-O \
141			-label [mc "Open..."]
142		bind $top <$M1B-o> [cb _next open]
143		bind $top <$M1B-O> [cb _next open]
144	}
145
146	$opts conf -state disabled
147
148	set sorted_recent [_get_recentrepos]
149	if {[llength $sorted_recent] > 0} {
150		if {$m_repo ne {}} {
151			$m_repo add separator
152			$m_repo add command \
153				-state disabled \
154				-label [mc "Recent Repositories"]
155		}
156
157	if {[set lenrecent [llength $sorted_recent]] < $maxrecent} {
158		set lenrecent $maxrecent
159	}
160
161		${NS}::label $w_body.space
162		${NS}::label $w_body.recentlabel \
163			-anchor w \
164			-text [mc "Open Recent Repository:"]
165		set w_recentlist $w_body.recentlist
166		text $w_recentlist \
167			-cursor $::cursor_ptr \
168			-relief flat \
169			-background [get_bg_color $w_body.recentlabel] \
170			-wrap none \
171			-width 50 \
172			-height $lenrecent
173		$w_recentlist tag conf link \
174			-foreground blue \
175			-underline 1
176		set home $::env(HOME)
177		if {[is_Cygwin]} {
178			set home [exec cygpath --windows --absolute $home]
179		}
180		set home "[file normalize $home]/"
181		set hlen [string length $home]
182		foreach p $sorted_recent {
183			set path $p
184			if {[string equal -length $hlen $home $p]} {
185				set p "~/[string range $p $hlen end]"
186			}
187			regsub -all "\n" $p "\\n" p
188			$w_recentlist insert end $p link
189			$w_recentlist insert end "\n"
190
191			if {$m_repo ne {}} {
192				$m_repo add command \
193					-command [cb _open_recent_path $path] \
194					-label "    $p"
195			}
196		}
197		$w_recentlist conf -state disabled
198		$w_recentlist tag bind link <1> [cb _open_recent %x,%y]
199		pack $w_body.space -anchor w -fill x
200		pack $w_body.recentlabel -anchor w -fill x
201		pack $w_recentlist -anchor w -fill x
202	}
203	pack $w_body -fill x -padx 10 -pady 10
204
205	${NS}::frame $w.buttons
206	set w_next $w.buttons.next
207	set w_quit $w.buttons.quit
208	${NS}::button $w_quit \
209		-text [mc "Quit"] \
210		-command exit
211	pack $w_quit -side right -padx 5
212	pack $w.buttons -side bottom -fill x -padx 10 -pady 10
213
214	if {$m_repo ne {}} {
215		$m_repo add separator
216		$m_repo add command \
217			-label [mc Quit] \
218			-command exit \
219			-accelerator $M1T-Q
220	}
221
222	bind $top <Return> [cb _invoke_next]
223	bind $top <Visibility> "
224		[cb _center]
225		grab $top
226		focus $top
227		bind $top <Visibility> {}
228	"
229	wm deiconify $top
230	tkwait variable @done
231
232	grab release $top
233	if {$top eq {.}} {
234		eval destroy [winfo children $top]
235	}
236}
237
238method _center {} {
239	set nx [winfo reqwidth $top]
240	set ny [winfo reqheight $top]
241	set rx [expr {([winfo screenwidth  $top] - $nx) / 3}]
242	set ry [expr {([winfo screenheight $top] - $ny) / 3}]
243	wm geometry $top [format {+%d+%d} $rx $ry]
244}
245
246method _invoke_next {} {
247	if {[winfo exists $w_next]} {
248		uplevel #0 [$w_next cget -command]
249	}
250}
251
252proc _get_recentrepos {} {
253	set recent [list]
254	foreach p [lsort -unique [get_config gui.recentrepo]] {
255		if {[_is_git [file join $p .git]]} {
256			lappend recent $p
257		} else {
258			_unset_recentrepo $p
259		}
260	}
261	return $recent
262}
263
264proc _unset_recentrepo {p} {
265	regsub -all -- {([()\[\]{}\.^$+*?\\])} $p {\\\1} p
266	catch {git config --global --unset-all gui.recentrepo "^$p\$"}
267	load_config 1
268}
269
270proc _append_recentrepos {path} {
271	set path [file normalize $path]
272	set recent [get_config gui.recentrepo]
273
274	if {[lindex $recent end] eq $path} {
275		return
276	}
277
278	set i [lsearch $recent $path]
279	if {$i >= 0} {
280		_unset_recentrepo $path
281	}
282
283	git config --global --add gui.recentrepo $path
284	load_config 1
285	set recent [get_config gui.recentrepo]
286
287	if {[set maxrecent [get_config gui.maxrecentrepo]] eq {}} {
288		set maxrecent 10
289	}
290
291	while {[llength $recent] > $maxrecent} {
292		_unset_recentrepo [lindex $recent 0]
293		set recent [get_config gui.recentrepo]
294	}
295}
296
297method _open_recent {xy} {
298	set id [lindex [split [$w_recentlist index @$xy] .] 0]
299	set local_path [lindex $sorted_recent [expr {$id - 1}]]
300	_do_open2 $this
301}
302
303method _open_recent_path {p} {
304	set local_path $p
305	_do_open2 $this
306}
307
308method _next {action} {
309	global NS
310	destroy $w_body
311	if {![winfo exists $w_next]} {
312		${NS}::button $w_next -default active
313		set pos -before
314		if {[tk windowingsystem] eq "win32"} { set pos -after }
315		pack $w_next -side right -padx 5 $pos $w_quit
316	}
317	_do_$action $this
318}
319
320method _write_local_path {args} {
321	if {$local_path eq {}} {
322		$w_next conf -state disabled
323	} else {
324		$w_next conf -state normal
325	}
326}
327
328method _git_init {} {
329	if {[catch {file mkdir $local_path} err]} {
330		error_popup [strcat \
331			[mc "Failed to create repository %s:" $local_path] \
332			"\n\n$err"]
333		return 0
334	}
335
336	if {[catch {cd $local_path} err]} {
337		error_popup [strcat \
338			[mc "Failed to create repository %s:" $local_path] \
339			"\n\n$err"]
340		return 0
341	}
342
343	if {[catch {git init} err]} {
344		error_popup [strcat \
345			[mc "Failed to create repository %s:" $local_path] \
346			"\n\n$err"]
347		return 0
348	}
349
350	_append_recentrepos [pwd]
351	set ::_gitdir .git
352	set ::_prefix {}
353	return 1
354}
355
356proc _is_git {path {outdir_var ""}} {
357	if {$outdir_var ne ""} {
358		upvar 1 $outdir_var outdir
359	}
360	if {[file isfile $path]} {
361		set fp [open $path r]
362		gets $fp line
363		close $fp
364		if {[regexp "^gitdir: (.+)$" $line line link_target]} {
365			set path [file join [file dirname $path] $link_target]
366			set path [file normalize $path]
367		}
368	}
369
370	if {[file exists [file join $path HEAD]]
371	 && [file exists [file join $path objects]]
372	 && [file exists [file join $path config]]} {
373		set outdir $path
374		return 1
375	}
376	if {[is_Cygwin]} {
377		if {[file exists [file join $path HEAD]]
378		 && [file exists [file join $path objects.lnk]]
379		 && [file exists [file join $path config.lnk]]} {
380			set outdir $path
381			return 1
382		}
383	}
384	return 0
385}
386
387proc _objdir {path} {
388	set objdir [file join $path .git objects]
389	if {[file isdirectory $objdir]} {
390		return $objdir
391	}
392
393	set objdir [file join $path objects]
394	if {[file isdirectory $objdir]} {
395		return $objdir
396	}
397
398	if {[is_Cygwin]} {
399		set objdir [file join $path .git objects.lnk]
400		if {[file isfile $objdir]} {
401			return [win32_read_lnk $objdir]
402		}
403
404		set objdir [file join $path objects.lnk]
405		if {[file isfile $objdir]} {
406			return [win32_read_lnk $objdir]
407		}
408	}
409
410	return {}
411}
412
413######################################################################
414##
415## Create New Repository
416
417method _do_new {} {
418	global use_ttk NS
419	$w_next conf \
420		-state disabled \
421		-command [cb _do_new2] \
422		-text [mc "Create"]
423
424	${NS}::frame $w_body
425	${NS}::label $w_body.h \
426		-font font_uibold -anchor center \
427		-text [mc "Create New Repository"]
428	pack $w_body.h -side top -fill x -pady 10
429	pack $w_body -fill x -padx 10
430
431	${NS}::frame $w_body.where
432	${NS}::label $w_body.where.l -text [mc "Directory:"]
433	${NS}::entry $w_body.where.t \
434		-textvariable @local_path \
435		-width 50
436	${NS}::button $w_body.where.b \
437		-text [mc "Browse"] \
438		-command [cb _new_local_path]
439	set w_localpath $w_body.where.t
440
441	grid $w_body.where.l $w_body.where.t $w_body.where.b -sticky ew
442	pack $w_body.where -fill x
443
444	grid columnconfigure $w_body.where 1 -weight 1
445
446	trace add variable @local_path write [cb _write_local_path]
447	bind $w_body.h <Destroy> [list trace remove variable @local_path write [cb _write_local_path]]
448	update
449	focus $w_body.where.t
450}
451
452method _new_local_path {} {
453	if {$local_path ne {}} {
454		set p [file dirname $local_path]
455	} else {
456		set p [pwd]
457	}
458
459	set p [tk_chooseDirectory \
460		-initialdir $p \
461		-parent $top \
462		-title [mc "Git Repository"] \
463		-mustexist false]
464	if {$p eq {}} return
465
466	set p [file normalize $p]
467	if {![_new_ok $p]} {
468		return
469	}
470	set local_path $p
471	$w_localpath icursor end
472}
473
474method _do_new2 {} {
475	if {![_new_ok $local_path]} {
476		return
477	}
478	if {![_git_init $this]} {
479		return
480	}
481	set done 1
482}
483
484proc _new_ok {p} {
485	if {[file isdirectory $p]} {
486		if {[_is_git [file join $p .git]]} {
487			error_popup [mc "Directory %s already exists." $p]
488			return 0
489		}
490	} elseif {[file exists $p]} {
491		error_popup [mc "File %s already exists." $p]
492		return 0
493	}
494	return 1
495}
496
497######################################################################
498##
499## Clone Existing Repository
500
501method _do_clone {} {
502	global use_ttk NS
503	$w_next conf \
504		-state disabled \
505		-command [cb _do_clone2] \
506		-text [mc "Clone"]
507
508	${NS}::frame $w_body
509	${NS}::label $w_body.h \
510		-font font_uibold -anchor center \
511		-text [mc "Clone Existing Repository"]
512	pack $w_body.h -side top -fill x -pady 10
513	pack $w_body -fill x -padx 10
514
515	set args $w_body.args
516	${NS}::frame $w_body.args
517	pack $args -fill both
518
519	${NS}::label $args.origin_l -text [mc "Source Location:"]
520	${NS}::entry $args.origin_t \
521		-textvariable @origin_url \
522		-width 50
523	${NS}::button $args.origin_b \
524		-text [mc "Browse"] \
525		-command [cb _open_origin]
526	grid $args.origin_l $args.origin_t $args.origin_b -sticky ew
527
528	${NS}::label $args.where_l -text [mc "Target Directory:"]
529	${NS}::entry $args.where_t \
530		-textvariable @local_path \
531		-width 50
532	${NS}::button $args.where_b \
533		-text [mc "Browse"] \
534		-command [cb _new_local_path]
535	grid $args.where_l $args.where_t $args.where_b -sticky ew
536	set w_localpath $args.where_t
537
538	${NS}::label $args.type_l -text [mc "Clone Type:"]
539	${NS}::frame $args.type_f
540	set w_types [list]
541	lappend w_types [${NS}::radiobutton $args.type_f.hardlink \
542		-state disabled \
543		-text [mc "Standard (Fast, Semi-Redundant, Hardlinks)"] \
544		-variable @clone_type \
545		-value hardlink]
546	lappend w_types [${NS}::radiobutton $args.type_f.full \
547		-state disabled \
548		-text [mc "Full Copy (Slower, Redundant Backup)"] \
549		-variable @clone_type \
550		-value full]
551	lappend w_types [${NS}::radiobutton $args.type_f.shared \
552		-state disabled \
553		-text [mc "Shared (Fastest, Not Recommended, No Backup)"] \
554		-variable @clone_type \
555		-value shared]
556	foreach r $w_types {
557		pack $r -anchor w
558	}
559	${NS}::checkbutton $args.type_f.recursive \
560		-text [mc "Recursively clone submodules too"] \
561		-variable @recursive \
562		-onvalue true -offvalue false
563	pack $args.type_f.recursive -anchor w
564	grid $args.type_l $args.type_f -sticky new
565
566	grid columnconfigure $args 1 -weight 1
567
568	trace add variable @local_path write [cb _update_clone]
569	trace add variable @origin_url write [cb _update_clone]
570	bind $w_body.h <Destroy> "
571		[list trace remove variable @local_path write [cb _update_clone]]
572		[list trace remove variable @origin_url write [cb _update_clone]]
573	"
574	update
575	focus $args.origin_t
576}
577
578method _open_origin {} {
579	if {$origin_url ne {} && [file isdirectory $origin_url]} {
580		set p $origin_url
581	} else {
582		set p [pwd]
583	}
584
585	set p [tk_chooseDirectory \
586		-initialdir $p \
587		-parent $top \
588		-title [mc "Git Repository"] \
589		-mustexist true]
590	if {$p eq {}} return
591
592	set p [file normalize $p]
593	if {![_is_git [file join $p .git]] && ![_is_git $p]} {
594		error_popup [mc "Not a Git repository: %s" [file tail $p]]
595		return
596	}
597	set origin_url $p
598}
599
600method _update_clone {args} {
601	if {$local_path ne {} && $origin_url ne {}} {
602		$w_next conf -state normal
603	} else {
604		$w_next conf -state disabled
605	}
606
607	if {$origin_url ne {} &&
608		(  [_is_git [file join $origin_url .git]]
609		|| [_is_git $origin_url])} {
610		set e normal
611		if {[[lindex $w_types 0] cget -state] eq {disabled}} {
612			set clone_type hardlink
613		}
614	} else {
615		set e disabled
616		set clone_type full
617	}
618
619	foreach r $w_types {
620		$r conf -state $e
621	}
622}
623
624method _do_clone2 {} {
625	if {[file isdirectory $origin_url]} {
626		set origin_url [file normalize $origin_url]
627	}
628
629	if {$clone_type eq {hardlink} && ![file isdirectory $origin_url]} {
630		error_popup [mc "Standard only available for local repository."]
631		return
632	}
633	if {$clone_type eq {shared} && ![file isdirectory $origin_url]} {
634		error_popup [mc "Shared only available for local repository."]
635		return
636	}
637
638	if {$clone_type eq {hardlink} || $clone_type eq {shared}} {
639		set objdir [_objdir $origin_url]
640		if {$objdir eq {}} {
641			error_popup [mc "Not a Git repository: %s" [file tail $origin_url]]
642			return
643		}
644	}
645
646	set giturl $origin_url
647	if {[is_Cygwin] && [file isdirectory $giturl]} {
648		set giturl [exec cygpath --unix --absolute $giturl]
649		if {$clone_type eq {shared}} {
650			set objdir [exec cygpath --unix --absolute $objdir]
651		}
652	}
653
654	if {[file exists $local_path]} {
655		error_popup [mc "Location %s already exists." $local_path]
656		return
657	}
658
659	if {![_git_init $this]} return
660	set local_path [pwd]
661
662	if {[catch {
663			git config remote.$origin_name.url $giturl
664			git config remote.$origin_name.fetch +refs/heads/*:refs/remotes/$origin_name/*
665		} err]} {
666		error_popup [strcat [mc "Failed to configure origin"] "\n\n$err"]
667		return
668	}
669
670	destroy $w_body $w_next
671
672	switch -exact -- $clone_type {
673	hardlink {
674		set o_status [status_bar::two_line $w_body]
675		pack $w_body -fill x -padx 10 -pady 10
676
677		set status_op [$o_status start \
678			[mc "Counting objects"] \
679			[mc "buckets"]]
680		update
681
682		if {[file exists [file join $objdir info alternates]]} {
683			set pwd [pwd]
684			if {[catch {
685				file mkdir [gitdir objects info]
686				set f_in [open [file join $objdir info alternates] r]
687				set f_cp [open [gitdir objects info alternates] w]
688				fconfigure $f_in -translation binary -encoding binary
689				fconfigure $f_cp -translation binary -encoding binary
690				cd $objdir
691				while {[gets $f_in line] >= 0} {
692					if {[is_Cygwin]} {
693						puts $f_cp [exec cygpath --unix --absolute $line]
694					} else {
695						puts $f_cp [file normalize $line]
696					}
697				}
698				close $f_in
699				close $f_cp
700				cd $pwd
701			} err]} {
702				catch {cd $pwd}
703				_clone_failed $this [mc "Unable to copy objects/info/alternates: %s" $err]
704				$status_op stop
705				return
706			}
707		}
708
709		set tolink  [list]
710		set buckets [glob \
711			-tails \
712			-nocomplain \
713			-directory [file join $objdir] ??]
714		set bcnt [expr {[llength $buckets] + 2}]
715		set bcur 1
716		$status_op update $bcur $bcnt
717		update
718
719		file mkdir [file join .git objects pack]
720		foreach i [glob -tails -nocomplain \
721			-directory [file join $objdir pack] *] {
722			lappend tolink [file join pack $i]
723		}
724		$status_op update [incr bcur] $bcnt
725		update
726
727		foreach i $buckets {
728			file mkdir [file join .git objects $i]
729			foreach j [glob -tails -nocomplain \
730				-directory [file join $objdir $i] *] {
731				lappend tolink [file join $i $j]
732			}
733			$status_op update [incr bcur] $bcnt
734			update
735		}
736		$status_op stop
737
738		if {$tolink eq {}} {
739			info_popup [strcat \
740				[mc "Nothing to clone from %s." $origin_url] \
741				"\n" \
742				[mc "The 'master' branch has not been initialized."] \
743				]
744			destroy $w_body
745			set done 1
746			return
747		}
748
749		set i [lindex $tolink 0]
750		if {[catch {
751				file link -hard \
752					[file join .git objects $i] \
753					[file join $objdir $i]
754			} err]} {
755			info_popup [mc "Hardlinks are unavailable.  Falling back to copying."]
756			set i [_copy_files $this $objdir $tolink]
757		} else {
758			set i [_link_files $this $objdir [lrange $tolink 1 end]]
759		}
760		if {!$i} return
761
762		destroy $w_body
763
764		set o_status {}
765	}
766	full {
767		set o_cons [console::embed \
768			$w_body \
769			[mc "Cloning from %s" $origin_url]]
770		pack $w_body -fill both -expand 1 -padx 10
771		$o_cons exec \
772			[list git fetch --no-tags -k $origin_name] \
773			[cb _do_clone_tags]
774	}
775	shared {
776		set fd [open [gitdir objects info alternates] w]
777		fconfigure $fd -translation binary
778		puts $fd $objdir
779		close $fd
780	}
781	}
782
783	if {$clone_type eq {hardlink} || $clone_type eq {shared}} {
784		if {![_clone_refs $this]} return
785		set pwd [pwd]
786		if {[catch {
787				cd $origin_url
788				set HEAD [git rev-parse --verify HEAD^0]
789			} err]} {
790			_clone_failed $this [mc "Not a Git repository: %s" [file tail $origin_url]]
791			return 0
792		}
793		cd $pwd
794		_do_clone_checkout $this $HEAD
795	}
796}
797
798method _copy_files {objdir tocopy} {
799	set status_op [$o_status start \
800		[mc "Copying objects"] \
801		[mc "KiB"]]
802	set tot 0
803	set cmp 0
804	foreach p $tocopy {
805		incr tot [file size [file join $objdir $p]]
806	}
807	foreach p $tocopy {
808		if {[catch {
809				set f_in [open [file join $objdir $p] r]
810				set f_cp [open [file join .git objects $p] w]
811				fconfigure $f_in -translation binary -encoding binary
812				fconfigure $f_cp -translation binary -encoding binary
813
814				while {![eof $f_in]} {
815					incr cmp [fcopy $f_in $f_cp -size 16384]
816					$status_op update \
817						[expr {$cmp / 1024}] \
818						[expr {$tot / 1024}]
819					update
820				}
821
822				close $f_in
823				close $f_cp
824			} err]} {
825			_clone_failed $this [mc "Unable to copy object: %s" $err]
826			$status_op stop
827			return 0
828		}
829	}
830	$status_op stop
831	return 1
832}
833
834method _link_files {objdir tolink} {
835	set total [llength $tolink]
836	set status_op [$o_status start \
837		[mc "Linking objects"] \
838		[mc "objects"]]
839	for {set i 0} {$i < $total} {} {
840		set p [lindex $tolink $i]
841		if {[catch {
842				file link -hard \
843					[file join .git objects $p] \
844					[file join $objdir $p]
845			} err]} {
846			_clone_failed $this [mc "Unable to hardlink object: %s" $err]
847			$status_op stop
848			return 0
849		}
850
851		incr i
852		if {$i % 5 == 0} {
853			$status_op update $i $total
854			update
855		}
856	}
857	$status_op stop
858	return 1
859}
860
861method _clone_refs {} {
862	set pwd [pwd]
863	if {[catch {cd $origin_url} err]} {
864		error_popup [mc "Not a Git repository: %s" [file tail $origin_url]]
865		return 0
866	}
867	set fd_in [git_read for-each-ref \
868		--tcl \
869		{--format=list %(refname) %(objectname) %(*objectname)}]
870	cd $pwd
871
872	set fd [open [gitdir packed-refs] w]
873	fconfigure $fd -translation binary
874	puts $fd "# pack-refs with: peeled"
875	while {[gets $fd_in line] >= 0} {
876		set line [eval $line]
877		set refn [lindex $line 0]
878		set robj [lindex $line 1]
879		set tobj [lindex $line 2]
880
881		if {[regsub ^refs/heads/ $refn \
882			"refs/remotes/$origin_name/" refn]} {
883			puts $fd "$robj $refn"
884		} elseif {[string match refs/tags/* $refn]} {
885			puts $fd "$robj $refn"
886			if {$tobj ne {}} {
887				puts $fd "^$tobj"
888			}
889		}
890	}
891	close $fd_in
892	close $fd
893	return 1
894}
895
896method _do_clone_tags {ok} {
897	if {$ok} {
898		$o_cons exec \
899			[list git fetch --tags -k $origin_name] \
900			[cb _do_clone_HEAD]
901	} else {
902		$o_cons done $ok
903		_clone_failed $this [mc "Cannot fetch branches and objects.  See console output for details."]
904	}
905}
906
907method _do_clone_HEAD {ok} {
908	if {$ok} {
909		$o_cons exec \
910			[list git fetch $origin_name HEAD] \
911			[cb _do_clone_full_end]
912	} else {
913		$o_cons done $ok
914		_clone_failed $this [mc "Cannot fetch tags.  See console output for details."]
915	}
916}
917
918method _do_clone_full_end {ok} {
919	$o_cons done $ok
920
921	if {$ok} {
922		destroy $w_body
923
924		set HEAD {}
925		if {[file exists [gitdir FETCH_HEAD]]} {
926			set fd [open [gitdir FETCH_HEAD] r]
927			while {[gets $fd line] >= 0} {
928				if {[regexp "^(.{40})\t\t" $line line HEAD]} {
929					break
930				}
931			}
932			close $fd
933		}
934
935		catch {git pack-refs}
936		_do_clone_checkout $this $HEAD
937	} else {
938		_clone_failed $this [mc "Cannot determine HEAD.  See console output for details."]
939	}
940}
941
942method _clone_failed {{why {}}} {
943	if {[catch {file delete -force $local_path} err]} {
944		set why [strcat \
945			$why \
946			"\n\n" \
947			[mc "Unable to cleanup %s" $local_path] \
948			"\n\n" \
949			$err]
950	}
951	if {$why ne {}} {
952		update
953		error_popup [strcat [mc "Clone failed."] "\n" $why]
954	}
955}
956
957method _do_clone_checkout {HEAD} {
958	if {$HEAD eq {}} {
959		info_popup [strcat \
960			[mc "No default branch obtained."] \
961			"\n" \
962			[mc "The 'master' branch has not been initialized."] \
963			]
964		set done 1
965		return
966	}
967	if {[catch {
968			git update-ref HEAD $HEAD^0
969		} err]} {
970		info_popup [strcat \
971			[mc "Cannot resolve %s as a commit." $HEAD^0] \
972			"\n  $err" \
973			"\n" \
974			[mc "The 'master' branch has not been initialized."] \
975			]
976		set done 1
977		return
978	}
979
980	set status [status_bar::two_line $w_body]
981	pack $w_body -fill x -padx 10 -pady 10
982
983	# We start the status operation here.
984	#
985	# This function calls _readtree_wait as a callback.
986	#
987	# _readtree_wait in turn either calls _do_clone_submodules directly,
988	# or calls _postcheckout_wait as a callback which then calls
989	# _do_clone_submodules.
990	#
991	# _do_clone_submodules calls _do_validate_submodule_cloning.
992	#
993	# _do_validate_submodule_cloning stops the status operation.
994	#
995	# There are no other calls into this chain from other code.
996
997	set o_status_op [$status start \
998		[mc "Creating working directory"] \
999		[mc "files"]]
1000
1001	set readtree_err {}
1002	set fd [git_read --stderr read-tree \
1003		-m \
1004		-u \
1005		-v \
1006		HEAD \
1007		HEAD \
1008		]
1009	fconfigure $fd -blocking 0 -translation binary
1010	fileevent $fd readable [cb _readtree_wait $fd]
1011}
1012
1013method _readtree_wait {fd} {
1014	set buf [read $fd]
1015	$o_status_op update_meter $buf
1016	append readtree_err $buf
1017
1018	fconfigure $fd -blocking 1
1019	if {![eof $fd]} {
1020		fconfigure $fd -blocking 0
1021		return
1022	}
1023
1024	if {[catch {close $fd}]} {
1025		set err $readtree_err
1026		regsub {^fatal: } $err {} err
1027		error_popup [strcat \
1028			[mc "Initial file checkout failed."] \
1029			"\n\n$err"]
1030		return
1031	}
1032
1033	# -- Run the post-checkout hook.
1034	#
1035	set fd_ph [githook_read post-checkout [string repeat 0 40] \
1036		[git rev-parse HEAD] 1]
1037	if {$fd_ph ne {}} {
1038		global pch_error
1039		set pch_error {}
1040		fconfigure $fd_ph -blocking 0 -translation binary -eofchar {}
1041		fileevent $fd_ph readable [cb _postcheckout_wait $fd_ph]
1042	} else {
1043		_do_clone_submodules $this
1044	}
1045}
1046
1047method _postcheckout_wait {fd_ph} {
1048	global pch_error
1049
1050	append pch_error [read $fd_ph]
1051	fconfigure $fd_ph -blocking 1
1052	if {[eof $fd_ph]} {
1053		if {[catch {close $fd_ph}]} {
1054			hook_failed_popup post-checkout $pch_error 0
1055		}
1056		unset pch_error
1057		_do_clone_submodules $this
1058		return
1059	}
1060	fconfigure $fd_ph -blocking 0
1061}
1062
1063method _do_clone_submodules {} {
1064	if {$recursive eq {true}} {
1065		$o_status_op stop
1066		set o_status_op {}
1067
1068		destroy $w_body
1069
1070		set o_cons [console::embed \
1071			$w_body \
1072			[mc "Cloning submodules"]]
1073		pack $w_body -fill both -expand 1 -padx 10
1074		$o_cons exec \
1075			[list git submodule update --init --recursive] \
1076			[cb _do_validate_submodule_cloning]
1077	} else {
1078		set done 1
1079	}
1080}
1081
1082method _do_validate_submodule_cloning {ok} {
1083	if {$ok} {
1084		$o_cons done $ok
1085		set done 1
1086	} else {
1087		_clone_failed $this [mc "Cannot clone submodules."]
1088	}
1089}
1090
1091######################################################################
1092##
1093## Open Existing Repository
1094
1095method _do_open {} {
1096	global NS
1097	$w_next conf \
1098		-state disabled \
1099		-command [cb _do_open2] \
1100		-text [mc "Open"]
1101
1102	${NS}::frame $w_body
1103	${NS}::label $w_body.h \
1104		-font font_uibold -anchor center \
1105		-text [mc "Open Existing Repository"]
1106	pack $w_body.h -side top -fill x -pady 10
1107	pack $w_body -fill x -padx 10
1108
1109	${NS}::frame $w_body.where
1110	${NS}::label $w_body.where.l -text [mc "Repository:"]
1111	${NS}::entry $w_body.where.t \
1112		-textvariable @local_path \
1113		-width 50
1114	${NS}::button $w_body.where.b \
1115		-text [mc "Browse"] \
1116		-command [cb _open_local_path]
1117
1118	grid $w_body.where.l $w_body.where.t $w_body.where.b -sticky ew
1119	pack $w_body.where -fill x
1120
1121	grid columnconfigure $w_body.where 1 -weight 1
1122
1123	trace add variable @local_path write [cb _write_local_path]
1124	bind $w_body.h <Destroy> [list trace remove variable @local_path write [cb _write_local_path]]
1125	update
1126	focus $w_body.where.t
1127}
1128
1129method _open_local_path {} {
1130	if {$local_path ne {}} {
1131		set p $local_path
1132	} else {
1133		set p [pwd]
1134	}
1135
1136	set p [tk_chooseDirectory \
1137		-initialdir $p \
1138		-parent $top \
1139		-title [mc "Git Repository"] \
1140		-mustexist true]
1141	if {$p eq {}} return
1142
1143	set p [file normalize $p]
1144	if {![_is_git [file join $p .git]]} {
1145		error_popup [mc "Not a Git repository: %s" [file tail $p]]
1146		return
1147	}
1148	set local_path $p
1149}
1150
1151method _do_open2 {} {
1152	if {![_is_git [file join $local_path .git] actualgit]} {
1153		error_popup [mc "Not a Git repository: %s" [file tail $local_path]]
1154		return
1155	}
1156
1157	if {[catch {cd $local_path} err]} {
1158		error_popup [strcat \
1159			[mc "Failed to open repository %s:" $local_path] \
1160			"\n\n$err"]
1161		return
1162	}
1163
1164	_append_recentrepos [pwd]
1165	set ::_gitdir $actualgit
1166	set ::_prefix {}
1167	set done 1
1168}
1169
1170}
1171