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 {[catch {set outdir [git rev-parse --resolve-git-dir $path]}]} {
361		return 0
362	}
363	return 1
364}
365
366proc _objdir {path} {
367	set objdir [file join $path .git objects]
368	if {[file isdirectory $objdir]} {
369		return $objdir
370	}
371
372	set objdir [file join $path objects]
373	if {[file isdirectory $objdir]} {
374		return $objdir
375	}
376
377	if {[is_Cygwin]} {
378		set objdir [file join $path .git objects.lnk]
379		if {[file isfile $objdir]} {
380			return [win32_read_lnk $objdir]
381		}
382
383		set objdir [file join $path objects.lnk]
384		if {[file isfile $objdir]} {
385			return [win32_read_lnk $objdir]
386		}
387	}
388
389	return {}
390}
391
392######################################################################
393##
394## Create New Repository
395
396method _do_new {} {
397	global use_ttk NS
398	$w_next conf \
399		-state disabled \
400		-command [cb _do_new2] \
401		-text [mc "Create"]
402
403	${NS}::frame $w_body
404	${NS}::label $w_body.h \
405		-font font_uibold -anchor center \
406		-text [mc "Create New Repository"]
407	pack $w_body.h -side top -fill x -pady 10
408	pack $w_body -fill x -padx 10
409
410	${NS}::frame $w_body.where
411	${NS}::label $w_body.where.l -text [mc "Directory:"]
412	${NS}::entry $w_body.where.t \
413		-textvariable @local_path \
414		-width 50
415	${NS}::button $w_body.where.b \
416		-text [mc "Browse"] \
417		-command [cb _new_local_path]
418	set w_localpath $w_body.where.t
419
420	grid $w_body.where.l $w_body.where.t $w_body.where.b -sticky ew
421	pack $w_body.where -fill x
422
423	grid columnconfigure $w_body.where 1 -weight 1
424
425	trace add variable @local_path write [cb _write_local_path]
426	bind $w_body.h <Destroy> [list trace remove variable @local_path write [cb _write_local_path]]
427	update
428	focus $w_body.where.t
429}
430
431method _new_local_path {} {
432	if {$local_path ne {}} {
433		set p [file dirname $local_path]
434	} else {
435		set p [pwd]
436	}
437
438	set p [tk_chooseDirectory \
439		-initialdir $p \
440		-parent $top \
441		-title [mc "Git Repository"] \
442		-mustexist false]
443	if {$p eq {}} return
444
445	set p [file normalize $p]
446	if {![_new_ok $p]} {
447		return
448	}
449	set local_path $p
450	$w_localpath icursor end
451}
452
453method _do_new2 {} {
454	if {![_new_ok $local_path]} {
455		return
456	}
457	if {![_git_init $this]} {
458		return
459	}
460	set done 1
461}
462
463proc _new_ok {p} {
464	if {[file isdirectory $p]} {
465		if {[_is_git [file join $p .git]]} {
466			error_popup [mc "Directory %s already exists." $p]
467			return 0
468		}
469	} elseif {[file exists $p]} {
470		error_popup [mc "File %s already exists." $p]
471		return 0
472	}
473	return 1
474}
475
476######################################################################
477##
478## Clone Existing Repository
479
480method _do_clone {} {
481	global use_ttk NS
482	$w_next conf \
483		-state disabled \
484		-command [cb _do_clone2] \
485		-text [mc "Clone"]
486
487	${NS}::frame $w_body
488	${NS}::label $w_body.h \
489		-font font_uibold -anchor center \
490		-text [mc "Clone Existing Repository"]
491	pack $w_body.h -side top -fill x -pady 10
492	pack $w_body -fill x -padx 10
493
494	set args $w_body.args
495	${NS}::frame $w_body.args
496	pack $args -fill both
497
498	${NS}::label $args.origin_l -text [mc "Source Location:"]
499	${NS}::entry $args.origin_t \
500		-textvariable @origin_url \
501		-width 50
502	${NS}::button $args.origin_b \
503		-text [mc "Browse"] \
504		-command [cb _open_origin]
505	grid $args.origin_l $args.origin_t $args.origin_b -sticky ew
506
507	${NS}::label $args.where_l -text [mc "Target Directory:"]
508	${NS}::entry $args.where_t \
509		-textvariable @local_path \
510		-width 50
511	${NS}::button $args.where_b \
512		-text [mc "Browse"] \
513		-command [cb _new_local_path]
514	grid $args.where_l $args.where_t $args.where_b -sticky ew
515	set w_localpath $args.where_t
516
517	${NS}::label $args.type_l -text [mc "Clone Type:"]
518	${NS}::frame $args.type_f
519	set w_types [list]
520	lappend w_types [${NS}::radiobutton $args.type_f.hardlink \
521		-state disabled \
522		-text [mc "Standard (Fast, Semi-Redundant, Hardlinks)"] \
523		-variable @clone_type \
524		-value hardlink]
525	lappend w_types [${NS}::radiobutton $args.type_f.full \
526		-state disabled \
527		-text [mc "Full Copy (Slower, Redundant Backup)"] \
528		-variable @clone_type \
529		-value full]
530	lappend w_types [${NS}::radiobutton $args.type_f.shared \
531		-state disabled \
532		-text [mc "Shared (Fastest, Not Recommended, No Backup)"] \
533		-variable @clone_type \
534		-value shared]
535	foreach r $w_types {
536		pack $r -anchor w
537	}
538	${NS}::checkbutton $args.type_f.recursive \
539		-text [mc "Recursively clone submodules too"] \
540		-variable @recursive \
541		-onvalue true -offvalue false
542	pack $args.type_f.recursive -anchor w
543	grid $args.type_l $args.type_f -sticky new
544
545	grid columnconfigure $args 1 -weight 1
546
547	trace add variable @local_path write [cb _update_clone]
548	trace add variable @origin_url write [cb _update_clone]
549	bind $w_body.h <Destroy> "
550		[list trace remove variable @local_path write [cb _update_clone]]
551		[list trace remove variable @origin_url write [cb _update_clone]]
552	"
553	update
554	focus $args.origin_t
555}
556
557method _open_origin {} {
558	if {$origin_url ne {} && [file isdirectory $origin_url]} {
559		set p $origin_url
560	} else {
561		set p [pwd]
562	}
563
564	set p [tk_chooseDirectory \
565		-initialdir $p \
566		-parent $top \
567		-title [mc "Git Repository"] \
568		-mustexist true]
569	if {$p eq {}} return
570
571	set p [file normalize $p]
572	if {![_is_git [file join $p .git]] && ![_is_git $p]} {
573		error_popup [mc "Not a Git repository: %s" [file tail $p]]
574		return
575	}
576	set origin_url $p
577}
578
579method _update_clone {args} {
580	if {$local_path ne {} && $origin_url ne {}} {
581		$w_next conf -state normal
582	} else {
583		$w_next conf -state disabled
584	}
585
586	if {$origin_url ne {} &&
587		(  [_is_git [file join $origin_url .git]]
588		|| [_is_git $origin_url])} {
589		set e normal
590		if {[[lindex $w_types 0] cget -state] eq {disabled}} {
591			set clone_type hardlink
592		}
593	} else {
594		set e disabled
595		set clone_type full
596	}
597
598	foreach r $w_types {
599		$r conf -state $e
600	}
601}
602
603method _do_clone2 {} {
604	if {[file isdirectory $origin_url]} {
605		set origin_url [file normalize $origin_url]
606	}
607
608	if {$clone_type eq {hardlink} && ![file isdirectory $origin_url]} {
609		error_popup [mc "Standard only available for local repository."]
610		return
611	}
612	if {$clone_type eq {shared} && ![file isdirectory $origin_url]} {
613		error_popup [mc "Shared only available for local repository."]
614		return
615	}
616
617	if {$clone_type eq {hardlink} || $clone_type eq {shared}} {
618		set objdir [_objdir $origin_url]
619		if {$objdir eq {}} {
620			error_popup [mc "Not a Git repository: %s" [file tail $origin_url]]
621			return
622		}
623	}
624
625	set giturl $origin_url
626	if {[is_Cygwin] && [file isdirectory $giturl]} {
627		set giturl [exec cygpath --unix --absolute $giturl]
628		if {$clone_type eq {shared}} {
629			set objdir [exec cygpath --unix --absolute $objdir]
630		}
631	}
632
633	if {[file exists $local_path]} {
634		error_popup [mc "Location %s already exists." $local_path]
635		return
636	}
637
638	if {![_git_init $this]} return
639	set local_path [pwd]
640
641	if {[catch {
642			git config remote.$origin_name.url $giturl
643			git config remote.$origin_name.fetch +refs/heads/*:refs/remotes/$origin_name/*
644		} err]} {
645		error_popup [strcat [mc "Failed to configure origin"] "\n\n$err"]
646		return
647	}
648
649	destroy $w_body $w_next
650
651	switch -exact -- $clone_type {
652	hardlink {
653		set o_status [status_bar::two_line $w_body]
654		pack $w_body -fill x -padx 10 -pady 10
655
656		set status_op [$o_status start \
657			[mc "Counting objects"] \
658			[mc "buckets"]]
659		update
660
661		if {[file exists [file join $objdir info alternates]]} {
662			set pwd [pwd]
663			if {[catch {
664				file mkdir [gitdir objects info]
665				set f_in [open [file join $objdir info alternates] r]
666				set f_cp [open [gitdir objects info alternates] w]
667				fconfigure $f_in -translation binary -encoding binary
668				fconfigure $f_cp -translation binary -encoding binary
669				cd $objdir
670				while {[gets $f_in line] >= 0} {
671					if {[is_Cygwin]} {
672						puts $f_cp [exec cygpath --unix --absolute $line]
673					} else {
674						puts $f_cp [file normalize $line]
675					}
676				}
677				close $f_in
678				close $f_cp
679				cd $pwd
680			} err]} {
681				catch {cd $pwd}
682				_clone_failed $this [mc "Unable to copy objects/info/alternates: %s" $err]
683				$status_op stop
684				return
685			}
686		}
687
688		set tolink  [list]
689		set buckets [glob \
690			-tails \
691			-nocomplain \
692			-directory [file join $objdir] ??]
693		set bcnt [expr {[llength $buckets] + 2}]
694		set bcur 1
695		$status_op update $bcur $bcnt
696		update
697
698		file mkdir [file join .git objects pack]
699		foreach i [glob -tails -nocomplain \
700			-directory [file join $objdir pack] *] {
701			lappend tolink [file join pack $i]
702		}
703		$status_op update [incr bcur] $bcnt
704		update
705
706		foreach i $buckets {
707			file mkdir [file join .git objects $i]
708			foreach j [glob -tails -nocomplain \
709				-directory [file join $objdir $i] *] {
710				lappend tolink [file join $i $j]
711			}
712			$status_op update [incr bcur] $bcnt
713			update
714		}
715		$status_op stop
716
717		if {$tolink eq {}} {
718			info_popup [strcat \
719				[mc "Nothing to clone from %s." $origin_url] \
720				"\n" \
721				[mc "The 'master' branch has not been initialized."] \
722				]
723			destroy $w_body
724			set done 1
725			return
726		}
727
728		set i [lindex $tolink 0]
729		if {[catch {
730				file link -hard \
731					[file join .git objects $i] \
732					[file join $objdir $i]
733			} err]} {
734			info_popup [mc "Hardlinks are unavailable.  Falling back to copying."]
735			set i [_copy_files $this $objdir $tolink]
736		} else {
737			set i [_link_files $this $objdir [lrange $tolink 1 end]]
738		}
739		if {!$i} return
740
741		destroy $w_body
742
743		set o_status {}
744	}
745	full {
746		set o_cons [console::embed \
747			$w_body \
748			[mc "Cloning from %s" $origin_url]]
749		pack $w_body -fill both -expand 1 -padx 10
750		$o_cons exec \
751			[list git fetch --no-tags -k $origin_name] \
752			[cb _do_clone_tags]
753	}
754	shared {
755		set fd [open [gitdir objects info alternates] w]
756		fconfigure $fd -translation binary
757		puts $fd $objdir
758		close $fd
759	}
760	}
761
762	if {$clone_type eq {hardlink} || $clone_type eq {shared}} {
763		if {![_clone_refs $this]} return
764		set pwd [pwd]
765		if {[catch {
766				cd $origin_url
767				set HEAD [git rev-parse --verify HEAD^0]
768			} err]} {
769			_clone_failed $this [mc "Not a Git repository: %s" [file tail $origin_url]]
770			return 0
771		}
772		cd $pwd
773		_do_clone_checkout $this $HEAD
774	}
775}
776
777method _copy_files {objdir tocopy} {
778	set status_op [$o_status start \
779		[mc "Copying objects"] \
780		[mc "KiB"]]
781	set tot 0
782	set cmp 0
783	foreach p $tocopy {
784		incr tot [file size [file join $objdir $p]]
785	}
786	foreach p $tocopy {
787		if {[catch {
788				set f_in [open [file join $objdir $p] r]
789				set f_cp [open [file join .git objects $p] w]
790				fconfigure $f_in -translation binary -encoding binary
791				fconfigure $f_cp -translation binary -encoding binary
792
793				while {![eof $f_in]} {
794					incr cmp [fcopy $f_in $f_cp -size 16384]
795					$status_op update \
796						[expr {$cmp / 1024}] \
797						[expr {$tot / 1024}]
798					update
799				}
800
801				close $f_in
802				close $f_cp
803			} err]} {
804			_clone_failed $this [mc "Unable to copy object: %s" $err]
805			$status_op stop
806			return 0
807		}
808	}
809	$status_op stop
810	return 1
811}
812
813method _link_files {objdir tolink} {
814	set total [llength $tolink]
815	set status_op [$o_status start \
816		[mc "Linking objects"] \
817		[mc "objects"]]
818	for {set i 0} {$i < $total} {} {
819		set p [lindex $tolink $i]
820		if {[catch {
821				file link -hard \
822					[file join .git objects $p] \
823					[file join $objdir $p]
824			} err]} {
825			_clone_failed $this [mc "Unable to hardlink object: %s" $err]
826			$status_op stop
827			return 0
828		}
829
830		incr i
831		if {$i % 5 == 0} {
832			$status_op update $i $total
833			update
834		}
835	}
836	$status_op stop
837	return 1
838}
839
840method _clone_refs {} {
841	set pwd [pwd]
842	if {[catch {cd $origin_url} err]} {
843		error_popup [mc "Not a Git repository: %s" [file tail $origin_url]]
844		return 0
845	}
846	set fd_in [git_read for-each-ref \
847		--tcl \
848		{--format=list %(refname) %(objectname) %(*objectname)}]
849	cd $pwd
850
851	set fd [open [gitdir packed-refs] w]
852	fconfigure $fd -translation binary
853	puts $fd "# pack-refs with: peeled"
854	while {[gets $fd_in line] >= 0} {
855		set line [eval $line]
856		set refn [lindex $line 0]
857		set robj [lindex $line 1]
858		set tobj [lindex $line 2]
859
860		if {[regsub ^refs/heads/ $refn \
861			"refs/remotes/$origin_name/" refn]} {
862			puts $fd "$robj $refn"
863		} elseif {[string match refs/tags/* $refn]} {
864			puts $fd "$robj $refn"
865			if {$tobj ne {}} {
866				puts $fd "^$tobj"
867			}
868		}
869	}
870	close $fd_in
871	close $fd
872	return 1
873}
874
875method _do_clone_tags {ok} {
876	if {$ok} {
877		$o_cons exec \
878			[list git fetch --tags -k $origin_name] \
879			[cb _do_clone_HEAD]
880	} else {
881		$o_cons done $ok
882		_clone_failed $this [mc "Cannot fetch branches and objects.  See console output for details."]
883	}
884}
885
886method _do_clone_HEAD {ok} {
887	if {$ok} {
888		$o_cons exec \
889			[list git fetch $origin_name HEAD] \
890			[cb _do_clone_full_end]
891	} else {
892		$o_cons done $ok
893		_clone_failed $this [mc "Cannot fetch tags.  See console output for details."]
894	}
895}
896
897method _do_clone_full_end {ok} {
898	$o_cons done $ok
899
900	if {$ok} {
901		destroy $w_body
902
903		set HEAD {}
904		if {[file exists [gitdir FETCH_HEAD]]} {
905			set fd [open [gitdir FETCH_HEAD] r]
906			while {[gets $fd line] >= 0} {
907				if {[regexp "^(.{40})\t\t" $line line HEAD]} {
908					break
909				}
910			}
911			close $fd
912		}
913
914		catch {git pack-refs}
915		_do_clone_checkout $this $HEAD
916	} else {
917		_clone_failed $this [mc "Cannot determine HEAD.  See console output for details."]
918	}
919}
920
921method _clone_failed {{why {}}} {
922	if {[catch {file delete -force $local_path} err]} {
923		set why [strcat \
924			$why \
925			"\n\n" \
926			[mc "Unable to cleanup %s" $local_path] \
927			"\n\n" \
928			$err]
929	}
930	if {$why ne {}} {
931		update
932		error_popup [strcat [mc "Clone failed."] "\n" $why]
933	}
934}
935
936method _do_clone_checkout {HEAD} {
937	if {$HEAD eq {}} {
938		info_popup [strcat \
939			[mc "No default branch obtained."] \
940			"\n" \
941			[mc "The 'master' branch has not been initialized."] \
942			]
943		set done 1
944		return
945	}
946	if {[catch {
947			git update-ref HEAD $HEAD^0
948		} err]} {
949		info_popup [strcat \
950			[mc "Cannot resolve %s as a commit." $HEAD^0] \
951			"\n  $err" \
952			"\n" \
953			[mc "The 'master' branch has not been initialized."] \
954			]
955		set done 1
956		return
957	}
958
959	set status [status_bar::two_line $w_body]
960	pack $w_body -fill x -padx 10 -pady 10
961
962	# We start the status operation here.
963	#
964	# This function calls _readtree_wait as a callback.
965	#
966	# _readtree_wait in turn either calls _do_clone_submodules directly,
967	# or calls _postcheckout_wait as a callback which then calls
968	# _do_clone_submodules.
969	#
970	# _do_clone_submodules calls _do_validate_submodule_cloning.
971	#
972	# _do_validate_submodule_cloning stops the status operation.
973	#
974	# There are no other calls into this chain from other code.
975
976	set o_status_op [$status start \
977		[mc "Creating working directory"] \
978		[mc "files"]]
979
980	set readtree_err {}
981	set fd [git_read --stderr read-tree \
982		-m \
983		-u \
984		-v \
985		HEAD \
986		HEAD \
987		]
988	fconfigure $fd -blocking 0 -translation binary
989	fileevent $fd readable [cb _readtree_wait $fd]
990}
991
992method _readtree_wait {fd} {
993	set buf [read $fd]
994	$o_status_op update_meter $buf
995	append readtree_err $buf
996
997	fconfigure $fd -blocking 1
998	if {![eof $fd]} {
999		fconfigure $fd -blocking 0
1000		return
1001	}
1002
1003	if {[catch {close $fd}]} {
1004		set err $readtree_err
1005		regsub {^fatal: } $err {} err
1006		error_popup [strcat \
1007			[mc "Initial file checkout failed."] \
1008			"\n\n$err"]
1009		return
1010	}
1011
1012	# -- Run the post-checkout hook.
1013	#
1014	set fd_ph [githook_read post-checkout [string repeat 0 40] \
1015		[git rev-parse HEAD] 1]
1016	if {$fd_ph ne {}} {
1017		global pch_error
1018		set pch_error {}
1019		fconfigure $fd_ph -blocking 0 -translation binary -eofchar {}
1020		fileevent $fd_ph readable [cb _postcheckout_wait $fd_ph]
1021	} else {
1022		_do_clone_submodules $this
1023	}
1024}
1025
1026method _postcheckout_wait {fd_ph} {
1027	global pch_error
1028
1029	append pch_error [read $fd_ph]
1030	fconfigure $fd_ph -blocking 1
1031	if {[eof $fd_ph]} {
1032		if {[catch {close $fd_ph}]} {
1033			hook_failed_popup post-checkout $pch_error 0
1034		}
1035		unset pch_error
1036		_do_clone_submodules $this
1037		return
1038	}
1039	fconfigure $fd_ph -blocking 0
1040}
1041
1042method _do_clone_submodules {} {
1043	if {$recursive eq {true}} {
1044		$o_status_op stop
1045		set o_status_op {}
1046
1047		destroy $w_body
1048
1049		set o_cons [console::embed \
1050			$w_body \
1051			[mc "Cloning submodules"]]
1052		pack $w_body -fill both -expand 1 -padx 10
1053		$o_cons exec \
1054			[list git submodule update --init --recursive] \
1055			[cb _do_validate_submodule_cloning]
1056	} else {
1057		set done 1
1058	}
1059}
1060
1061method _do_validate_submodule_cloning {ok} {
1062	if {$ok} {
1063		$o_cons done $ok
1064		set done 1
1065	} else {
1066		_clone_failed $this [mc "Cannot clone submodules."]
1067	}
1068}
1069
1070######################################################################
1071##
1072## Open Existing Repository
1073
1074method _do_open {} {
1075	global NS
1076	$w_next conf \
1077		-state disabled \
1078		-command [cb _do_open2] \
1079		-text [mc "Open"]
1080
1081	${NS}::frame $w_body
1082	${NS}::label $w_body.h \
1083		-font font_uibold -anchor center \
1084		-text [mc "Open Existing Repository"]
1085	pack $w_body.h -side top -fill x -pady 10
1086	pack $w_body -fill x -padx 10
1087
1088	${NS}::frame $w_body.where
1089	${NS}::label $w_body.where.l -text [mc "Repository:"]
1090	${NS}::entry $w_body.where.t \
1091		-textvariable @local_path \
1092		-width 50
1093	${NS}::button $w_body.where.b \
1094		-text [mc "Browse"] \
1095		-command [cb _open_local_path]
1096
1097	grid $w_body.where.l $w_body.where.t $w_body.where.b -sticky ew
1098	pack $w_body.where -fill x
1099
1100	grid columnconfigure $w_body.where 1 -weight 1
1101
1102	trace add variable @local_path write [cb _write_local_path]
1103	bind $w_body.h <Destroy> [list trace remove variable @local_path write [cb _write_local_path]]
1104	update
1105	focus $w_body.where.t
1106}
1107
1108method _open_local_path {} {
1109	if {$local_path ne {}} {
1110		set p $local_path
1111	} else {
1112		set p [pwd]
1113	}
1114
1115	set p [tk_chooseDirectory \
1116		-initialdir $p \
1117		-parent $top \
1118		-title [mc "Git Repository"] \
1119		-mustexist true]
1120	if {$p eq {}} return
1121
1122	set p [file normalize $p]
1123	if {![_is_git [file join $p .git]]} {
1124		error_popup [mc "Not a Git repository: %s" [file tail $p]]
1125		return
1126	}
1127	set local_path $p
1128}
1129
1130method _do_open2 {} {
1131	if {![_is_git [file join $local_path .git] actualgit]} {
1132		error_popup [mc "Not a Git repository: %s" [file tail $local_path]]
1133		return
1134	}
1135
1136	if {[catch {cd $local_path} err]} {
1137		error_popup [strcat \
1138			[mc "Failed to open repository %s:" $local_path] \
1139			"\n\n$err"]
1140		return
1141	}
1142
1143	_append_recentrepos [pwd]
1144	set ::_gitdir $actualgit
1145	set ::_prefix {}
1146	set done 1
1147}
1148
1149}
1150