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