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