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