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