lib/choose_repository.tcl

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