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