tk/mc.tcl

   1 # Midnight Commander Tk code.
   2 # Copyright (C) 1995, 1996, 1997 Miguel de Icaza
   3 #
   4 #
   5 #   Todo:
   6 #     Fix the internal viewer
   7 #     Missing commands: mc_file_info, mc_open_with
   8 #     The default buttons have a problem with the new frame around them:
   9 #     they don't display the focus.
  10 #
  11 #   This program is free software; you can redistribute it and/or modify
  12 #   it under the terms of the GNU General Public License as published by
  13 #   the Free Software Foundation; either version 2 of the License, or
  14 #   (at your option) any later version.
  15 #
  16 #   This program is distributed in the hope that it will be useful,
  17 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 #   GNU General Public License for more details.
  20 #
  21 #   You should have received a copy of the GNU General Public License
  22 #   along with this program; if not, write to the Free Software
  23 #   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  24
  25 wm iconname . tkmc
  26 wm title    . "Midnight Commander (TK edition)"
  27
  28 #
  29 # Menu routines
  30 #
  31 proc create_top_menu {} {
  32     global top_menus
  33     global setup
  34     set top_menus ""
  35
  36     frame .mbar -relief raised -bd 2
  37
  38     pack .mbar -side top -fill x
  39 }
  40
  41 #
  42 # Widget: WMenu
  43 #
  44 proc create_menu {str topmenu} {
  45     global top_menus
  46     global setup
  47
  48     menubutton .mbar.$topmenu -text $str -underline 0 -menu .mbar.$topmenu.menu
  49     pack .mbar.$topmenu -side left
  50     menu .mbar.$topmenu.menu -tearoff $setup(tearoff)
  51     set top_menus "$top_menus $topmenu"
  52 }
  53
  54 proc create_mentry {topmenu entry cmd idx} {
  55     .mbar.$topmenu.menu add command -label "$entry" -command "$cmd $idx"
  56 }
  57
  58 proc add_separator {topmenu} {
  59     .mbar.$topmenu.menu add separator
  60 }
  61
  62 #
  63 # Widget: WButton
  64 #
  65 proc newbutton {name cmd text isdef} {
  66     if $isdef {
  67         frame $name -relief sunken -bd 1
  68         set name "$name.button"
  69     }
  70     button $name -text "$text" -command $cmd -justify left
  71     if $isdef {
  72         pack $name -padx 1m -pady 1m
  73     }
  74 }
  75
  76 #
  77 # Widget: WGauge
  78 #
  79 proc newgauge {win} {
  80     global setup
  81
  82     canvas $win -height $setup(heightc) -width 250 -relief sunken -border 2
  83     $win create rectangle 0 0 0 0 -tags gauge -fill black -stipple gray50
  84
  85     # So that we can tell the C code, which is the gauge size currently
  86     bind $win <Configure> "x$win %w"
  87 }
  88
  89 # Used to show the gauge information
  90 proc gauge_shown {win} {
  91     # $win configure -relief sunken -border 2
  92 }
  93
  94 # Used to hide the gauge information.
  95 proc gauge_hidden {win} {
  96     # $win configure -relief flat -border 0
  97     $win coords gauge 0 0 0 0
  98 }
  99
 100 #
 101 # Widget: WView
 102 #
 103 proc view_size {cmd w h} {
 104     global setup
 105
 106     $cmd dim [expr $w/$setup(widthc)] [expr $h/$setup(heightc)]
 107 }
 108
 109 proc newview {is_panel container winname cmd} {
 110     global setup
 111
 112     # FIXME: The trick to get the window without too much
 113     # movement/flicker is to use an extra frame, and use the placer
 114     # like it was done in WInfo.
 115     if $is_panel {
 116         set width  [expr [winfo width $container]/$setup(widthc)]
 117         set height [expr [winfo height $container]/$setup(heightc)]
 118     }
 119
 120     frame $winname
 121     frame $winname.v
 122     frame $winname.v.status
 123     eval text $winname.v.view $setup(view_normal) -font $setup(panelfont)
 124
 125     # Create the tag names for the viewer attributes
 126     eval $winname.v.view tag configure bold $setup(view_bold)
 127     eval $winname.v.view tag configure underline $setup(view_underline)
 128     eval $winname.v.view tag configure mark $setup(view_mark)
 129     eval $winname.v.view tag configure normal $setup(view_normal)
 130
 131     # Make the status fields
 132     label $winname.v.status.filename
 133     label $winname.v.status.column
 134     label $winname.v.status.size
 135     label $winname.v.status.flags
 136
 137     pack $winname.v.status.filename -side left
 138     pack $winname.v.status.column   -anchor w -side left -fill x -expand 1
 139     pack $winname.v.status.size     -anchor w -side left -fill x -expand 1
 140     pack $winname.v.status.flags    -anchor w -side left -fill x -expand 1
 141
 142     # Pack the main components
 143     pack $winname.v.status -side top -fill x
 144     pack $winname.v.view -side bottom -expand 1 -fill both
 145     pack $winname.v -expand 1 -fill both
 146
 147     bindtags $winname.v.view "all . $winname.v.view"
 148     bind $winname.v.view <Configure> "view_size $cmd %w %h"
 149
 150     if $is_panel {
 151         $winname.v.view configure -width $width -height $height
 152         pack $winname
 153     }
 154 }
 155
 156 proc view_update_info {win fname col size flags} {
 157     $win.v.status.filename configure -text "File: $fname"
 158     $win.v.status.column   configure -text "Column: $col"
 159     $win.v.status.size     configure -text "$size bytes"
 160     $win.v.status.flags    configure -text "$flags"
 161 }
 162
 163 #
 164 # Hack: remove all the text on the window and then insert
 165 # new lines.  Maybe the newlines
 166 proc cleanview {win} {
 167     $win delete 1.0 end
 168     $win insert 1.0 "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n"
 169 }
 170
 171 #
 172 # Widget: WRadio
 173 #
 174 proc newradio {name} {
 175     frame $name
 176     global last_radio
 177     set last_radio $name
 178 }
 179
 180 proc radio_item {idx text cmd act} {
 181      global last_radio
 182      radiobutton $last_radio.$idx -text "$text" -variable v$last_radio -value $idx -command "$cmd select $idx"
 183      if $act {
 184          $last_radio.$idx select
 185      }
 186      pack $last_radio.$idx -side top -anchor w
 187 }
 188
 189 #
 190 # Widget: Input
 191 #
 192 #
 193
 194 proc entry_save_sel {win} {
 195     global sel
 196
 197     if [$win selection present] {
 198         set sel(pres) 1
 199         set sel(first) [$win index sel.first]
 200         set sel(last)  [$win index sel.last]
 201     } else {
 202         set sel(pres) 0
 203     }
 204 }
 205
 206 proc entry_restore_sel {win} {
 207     global sel
 208
 209     if $sel(pres) {
 210         $win selection from $sel(first)
 211         $win selection to $sel(last)
 212     }
 213 }
 214
 215 proc entry_click {win x} {
 216     global sel
 217     set p [$win index @$x]
 218     x$win mouse $p
 219     x$win setmark
 220     set sel(from) $p
 221 }
 222
 223 proc entry_move {win x} {
 224     global sel
 225     set p [$win index @$x]
 226     $win selection from $sel(from)
 227     $win selection to $p
 228     x$win mouse $p
 229 }
 230
 231 proc bind_entry {win} {
 232     bind $win <1>         "entry_click $win %x"
 233     bind $win <B1-Motion> "entry_move $win %x"
 234 }
 235
 236 proc newinput {name text} {
 237     entry $name -relief sunken -background white -foreground black
 238     $name insert 0 "$text"
 239     bindtags $name "all . $name "
 240     bind_entry $name
 241 }
 242
 243 #
 244 # Widget: WCheck
 245 #
 246 proc newcheck {name cmd text act} {
 247     checkbutton $name -text "$text" -command "$cmd"
 248     if $act { $name select }
 249 }
 250
 251 #
 252 # Widget: WInfo
 253 #
 254 # window is the container name and widget name: .left.o2
 255 # container is the container name: .left
 256 #
 257     proc info_entry {win name text} {
 258         frame $win.b.finfo.$name
 259         label $win.b.finfo.$name.label -text "$text"
 260         label $win.b.finfo.$name.info
 261         grid $win.b.finfo.$name.label -row 0 -column 0 -sticky we
 262         grid $win.b.finfo.$name.info -row 0 -column 1 -sticky w
 263         grid columnconfigure $win.b.finfo.$name 0 -minsize 100
 264     }
 265
 266 proc newinfo {container window version} {
 267     global setup
 268
 269     set width  [winfo width $container]
 270     set height [winfo height $container]
 271
 272     frame $window -width $width -height $height \
 273         -borderwidth [expr $setup(widthc)/2]
 274
 275     frame $window.b
 276     frame $window.b.v
 277     frame $window.b.finfo -relief groove -borderwidth 2
 278     frame $window.b.fs -relief groove -borderwidth 2
 279
 280     label $window.b.v.version -text "  The Midnight Commander $version  " \
 281         -relief groove
 282     pack  $window.b.v.version -fill x
 283
 284     info_entry $window fname    "File:"
 285     info_entry $window location "Location:"
 286     info_entry $window mode     "Mode:"
 287     info_entry $window links    "Links:"
 288     info_entry $window owner    "Owner:"
 289     info_entry $window size     "Size:"
 290     info_entry $window created  "Created:"
 291     info_entry $window modified "Modified:"
 292     info_entry $window access   "Access:"
 293
 294     pack  $window.b.finfo.fname \
 295         $window.b.finfo.location $window.b.finfo.mode $window.b.finfo.links \
 296         $window.b.finfo.owner $window.b.finfo.size $window.b.finfo.created \
 297         $window.b.finfo.modified $window.b.finfo.access \
 298         -side top -anchor w
 299
 300     label $window.b.fs.fsys
 301     label $window.b.fs.dev
 302     label $window.b.fs.type
 303
 304     frame  $window.b.fs.free
 305     label  $window.b.fs.free.label
 306     newcanvas $window.b.fs.free.canvas
 307
 308     pack $window.b.fs.free.label -side left
 309     pack $window.b.fs.free.canvas -side left
 310
 311     frame  $window.b.fs.freeino
 312     label  $window.b.fs.freeino.label
 313     newcanvas $window.b.fs.freeino.canvas
 314     pack  $window.b.fs.freeino.label -side left
 315     pack  $window.b.fs.freeino.canvas -side left
 316
 317     pack $window.b.fs.fsys \
 318         $window.b.fs.dev $window.b.fs.type \
 319         $window.b.fs.free \
 320         $window.b.fs.freeino -side top -anchor w -padx $setup(widthc)
 321
 322     pack $window.b.v -side top -anchor w -fill x -expand 1
 323
 324     pack $window.b.fs -side bottom -anchor w -fill x -expand 1
 325
 326     pack $window.b.finfo -side top -anchor w \
 327         -fill x -expand 1
 328
 329     pack $window.b
 330
 331     pack $window -fill both -expand 1
 332 #    pack $window.b
 333     place $window.b -in $window -relx 0 -rely 0 -relheight 1 -relwidth 1
 334 }
 335
 336 proc info_bar {win percent} {
 337     global setup
 338     set w [winfo width $win]
 339     set s [expr (100-$percent)*$w/100]
 340
 341     $win coords bar 0 0 $s 50
 342 #    puts stderr "Width: $w $s\n\r"
 343 }
 344
 345 proc info_none {win} {
 346     $win coords bar 0 0 0 0
 347
 348 }
 349
 350 proc newcanvas {win} {
 351     global setup
 352     canvas $win -height $setup(heightc) -relief sunken -border 2
 353     $win create rectangle 0 0 0 0 -tags bar -fill black -stipple gray50
 354 }
 355
 356 proc infotext {win text} {
 357     $win configure -text $text
 358 }
 359
 360 proc xinfotext {win text} {
 361     $win.info configure -text $text
 362 }
 363     # w containes the window name *and* the .b frame (like: .left.o2.b)
 364     # FIXME: We should also display the rdev information
 365 proc info_update {w
 366                   fname dev ino
 367                   mode mode_oct
 368                   links owner group
 369                   have_blocks blocks
 370                   size
 371                   have_rdev rdev rdev2
 372                   create modify access
 373                   fsys dev type
 374                   have_space avail percent total
 375                   have_ino   nfree inoperc inotot} {
 376
 377     #
 378     # Set all the text information
 379     #
 380     xinfotext $w.finfo.fname    "$fname"
 381     xinfotext $w.finfo.location "${dev}h:${ino}h"
 382     xinfotext $w.finfo.mode     "$mode ($mode_oct)"
 383     xinfotext $w.finfo.links    "$links"
 384     xinfotext $w.finfo.owner    "$owner/$group"
 385     if $have_blocks {
 386         xinfotext $w.finfo.size     "$size ($blocks blocks)"
 387     } else {
 388         xinfotext $w.finfo.size     "$size"
 389     }
 390     xinfotext $w.finfo.created  "$create"
 391     xinfotext $w.finfo.modified "$modify"
 392     xinfotext $w.finfo.access   "$access"
 393
 394     infotext $w.fs.fsys "Filesystem:\t$fsys"
 395     infotext $w.fs.dev  "Device:\t\t$dev"
 396     infotext $w.fs.type "Type:\t\t$type"
 397     if $have_space {
 398         infotext $w.fs.free.label \
 399            "Free Space $avail ($percent%) of $total"
 400         info_bar $w.fs.free.canvas $percent
 401     } else {
 402         infotext $w.fs.free.label "No space information"
 403         info_none $w.fs.free.canvas
 404     }
 405     if $have_ino {
 406         infotext $w.fs.freeino.label \
 407            "Free inodes $nfree ($inoperc%) of $inotot"
 408         info_bar $w.fs.freeino.canvas $inoperc
 409     } else {
 410         infotext $w.fs.freeino.label "No inode information"
 411         info_none $w.fs.freeino.canvas
 412     }
 413 }
 414
 415 #
 416 #  Widget: listbox
 417 #
 418 proc listbox_sel {win item} {
 419     $win selection clear 0 end
 420     $win selection set $item
 421     $win see $item
 422 }
 423
 424 #
 425 # Widget: WPanel
 426 #
 427 proc panel_select {w pos cback} {
 428     $w.m.p.panel tag add selected $pos.0 "$pos.0 lineend"
 429     $w.m.p.panel see $pos.0
 430     $cback top [$w.m.p.panel index @0,0]
 431 }
 432
 433 proc panel_scroll {win cback args} {
 434     eval "$win yview $args"
 435     $cback top [$win index @0,0]
 436 }
 437
 438 proc cmd_sort_add {name menu cmd} {
 439     $menu add command -label $name -command "$cmd sort $name"
 440 }
 441
 442 proc panel_setup {which cmd} {
 443     global setup
 444
 445     frame $which
 446     set m $which.cwd.menu
 447     menubutton $which.cwd -text "loading..." -bd 1 -relief raised \
 448         -menu $m -indicatoron 0
 449     menu $m -tearoff 0
 450         menu [set mm $m.sort] -tearoff 0
 451         $m add command -label "Reverse sort order" -command "$cmd reverse"
 452         $m add cascade -label "Sort" -menu $mm
 453             cmd_sort_add "Name"  $mm $cmd
 454             cmd_sort_add "Extension" $mm $cmd
 455             cmd_sort_add "Size"  $mm $cmd
 456             cmd_sort_add "Modify Time" $mm $cmd
 457             cmd_sort_add "Access Time" $mm $cmd
 458             cmd_sort_add "Change Time" $mm $cmd
 459             cmd_sort_add "Inode" $mm $cmd
 460             cmd_sort_add "Type"  $mm $cmd
 461             cmd_sort_add "Links" $mm $cmd
 462             cmd_sort_add "NGID"  $mm $cmd
 463             cmd_sort_add "NUID"  $mm $cmd
 464             cmd_sort_add "Owner" $mm $cmd
 465             cmd_sort_add "Group" $mm $cmd
 466             cmd_sort_add "Unsorted" $mm $cmd
 467
 468         $m add command -label "Refresh" -command "$cmd refresh"
 469         $m add separator
 470         $m add command -label "Set mask" -command "$cmd setmask"
 471         $m add command -label "No mask"  -command "$cmd nomask"
 472
 473     frame $which.m
 474     label $which.mini
 475     scrollbar $which.m.scroll -width 3m
 476
 477     frame $which.m.p -relief sunken -borderwidth 2
 478         # The sort bar
 479         if $setup(with_sortbar) {
 480             canvas $which.m.p.types \
 481                     -borderwidth 0\
 482                     -back $setup(def_back) \
 483                     -highlightthickness 0 -height 0
 484             pack $which.m.p.types  -side top -fill x
 485         }
 486
 487         scrollbar $which.m.p.scroll -width 3m -orient horizontal
 488
 489         # The file listing panel
 490         text  $which.m.p.panel -width $setup(cols) -yscroll "$which.m.scroll set" \
 491             -fore $setup(def_fore) -back $setup(def_back) \
 492             -wrap none -height $setup(lines) -font $setup(panelfont)  \
 493             -relief flat -borderwidth 0 -highlightthickness 0 \
 494             -xscroll "$which.m.p.scroll set"
 495
 496         bindtags $which.m.p.panel "all . $which.m.p.panel"
 497
 498         proc x$which.m.p.panel {x} "$cmd \$x"
 499
 500         pack $which.m.p.panel  -side top  -fill both -expand 1
 501         pack $which.m.p.scroll -side top  -fill x
 502         pack $which.m.p        -side left -fill both -expand 1
 503
 504     pack $which.m.scroll -side right -fill y
 505     pack $which.cwd  -side top -anchor w
 506     pack $which.m    -side top -fill both -expand 1
 507     pack $which.mini -side top -fill x
 508
 509     pack $which -fill both -expand 1
 510
 511     config_colors $which.m.p.panel
 512 }
 513
 514     #
 515     # Draging the panels:
 516     # mc_x and mc_y contains the last positions where the mouse was
 517     # mc_repeat     contains the id of the after command.
 518     #
 519 proc panel_cancel_repeat {} {
 520     global mc_repeat
 521
 522     after cancel $mc_repeat
 523     set mc_repeat {}
 524 }
 525
 526 proc panel_drag {w cmd n} {
 527     global mc_y
 528     global mc_x
 529     global mc_repeat
 530
 531     if {$mc_y >= [winfo height $w]} {
 532         $w yview scroll 1 units
 533     } elseif {$mc_y < 0} {
 534         $w yview scroll -1 units
 535     } else {
 536         return
 537     }
 538     $cmd top [$w index @0,0]
 539     $cmd motion $n [$w index @$mc_x,$mc_y]
 540     set mc_repeat [after 50 panel_drag $w $cmd $n]
 541 }
 542
 543     #
 544     #  This routine passes the size of the text widget back to the C code
 545     #
 546
 547 proc panel_size {cmd panel w h} {
 548     global setup
 549
 550     set setup(real_height) $h
 551     set setup(real_width)  $w
 552
 553     if $setup(with_icons) {
 554         set setup(height) [expr $h-setup(iconheight)]
 555         set setup(width)  [expr $w-$setup(iconwidth)]
 556         set setup(lines)  [expr $setup(height)/$setup(heightc)]
 557         set setup(cols)   [expr $setup(width)/$setup(widthc)]
 558     } else {
 559         set setup(height) $h
 560         set setup(width)  $w
 561         set setup(lines)  [expr $h/$setup(heightc)]
 562         set setup(cols)   [expr $w/$setup(widthc)]
 563     }
 564     $cmd resize $panel
 565 }
 566
 567     #
 568     # Called on the first idle loop to configure the sizes of the thing
 569     #
 570 proc panel_conf {panel cmd} {
 571     global setup
 572
 573     set font [lindex [$panel configure -font] 4]
 574     set fontinfo [$cmd fontdim $font $panel]
 575
 576     set setup(heightc) [lindex $fontinfo 0]
 577     set setup(widthc)  [lindex $fontinfo 1]
 578
 579     bind $panel <Configure> "panel_size $cmd $panel %w %h"
 580 }
 581
 582 #
 583 # Manage the bar that keeps the sort orders
 584 #
 585 proc panel_reset_sort_labels {win} {
 586 #    $win.m.p.types delete all
 587 }
 588
 589 proc panel_sort_label_start {win} {
 590 #    $win.m.p.types delete all
 591 }
 592
 593 #
 594 # This right now uses a canvas, creates labels and places them
 595 # on the canvas.  The button emulation is done with a manual
 596 # bind.
 597 #
 598
 599 proc panel_add_sort {win text_len text pos end_pos tag} {
 600     global setup
 601
 602     if {$setup(with_sortbar) == 0} return
 603
 604     catch { destroy $win.m.p.types.$pos }
 605     label $win.m.p.types.$pos -text $text -borderwidth 2 \
 606             -font $setup(panelfont) -relief raised
 607
 608     $win.m.p.types create window $pos 0 -window $win.m.p.types.$pos -anchor nw
 609     $win.m.p.types configure -height [expr $setup(heightc)+8]
 610     $win.m.p.types create line $end_pos 1 $end_pos [expr $setup(heightc)-1] -fill gray
 611
 612     # Simulate the button.
 613     bind $win.m.p.types.$pos <Button-1> "
 614         $win.m.p.types.$pos configure -relief sunken
 615         x$win sort $tag
 616         after 100 { $win.m.p.types.$pos configure -relief raised }
 617      "
 618 }
 619
 620 #
 621 # Called back from the action menu
 622 #
 623 proc popup_add_action {filename cmd idx} {
 624     global setup
 625     menu [set m .m.action] -tearoff 0
 626         .m add cascade -foreground $setup(action_foreground) -label "$filename" -menu $m
 627         $m add command -label "Info"            -command "mc_file_info \"$filename\""
 628         $m add command -label "Open with..."    -command "mc_open_with \"$filename\""
 629         $m add separator
 630         $m add command -label "Copy..."         -command "$cmd invoke %d Copy"
 631         $m add command -label "Rename, move..." -command "$cmd invoke %d Move"
 632         $m add command -label "Delete..."       -command "$cmd invoke %d Delete"
 633         $m add separator
 634         $m add command -label "Open"            -command "$cmd invoke %d Open"
 635         $m add command -label "View"            -command "$cmd invoke %d View"
 636 }
 637
 638 proc start_drag {mode panel_cmd W x y X Y} {
 639     global drag_mode
 640     global drag_text
 641
 642     set drag_mode $mode
 643     set drag_text [$panel_cmd dragtext [$W index @$x,$y]]
 644     set drag_text "$mode $drag_text"
 645
 646     catch {destroy .drag}
 647     toplevel .drag
 648     wm overrideredirect .drag 1
 649     wm withdraw .drag
 650     label .drag.text -text "$drag_text"
 651     pack .drag.text
 652     wm deiconify .drag
 653     wm geometry .drag +$X+$Y
 654 }
 655
 656 proc drag_test {token} {
 657     if {[winfo children $token] == ""} {
 658         label $token.value -text "Zonzo"
 659         pack $token.value
 660     }
 661     $token.value configure -text Hla
 662     return "caca";
 663 }
 664
 665 proc mc_drag_target {} {
 666     global DragDrop
 667
 668     set data $DragDrop(text)
 669 }
 670
 671 proc mc_drag_send {} {
 672 #    puts "drag send"
 673 }
 674
 675     #
 676     # Mouse bindings for the panels
 677     #
 678 proc panel_bind {the_panel panel_cmd} {
 679     global setup
 680
 681     set pn "$the_panel.m.p.panel"
 682
 683     bind $pn <Button-1> "
 684         $panel_cmd mdown 2  \[%W index @%x,%y]
 685     "
 686
 687     bind $pn <ButtonRelease-1> "
 688         panel_cancel_repeat
 689         $panel_cmd mup 2    \[%W index @%x,%y]"
 690
 691     bind $pn <Double-1> "
 692         panel_cancel_repeat
 693         $panel_cmd double 2 \[%W index @%x,%y]"
 694
 695     bind $pn <B1-Motion> "
 696        set mc_x %x
 697        set mc_y %y
 698        $panel_cmd motion 2 \[%W index @%x,%y]
 699     "
 700
 701     bind $pn <B1-Leave> "
 702         set mc_x %x
 703         set mc_y %y
 704         panel_drag %W $panel_cmd 2
 705     "
 706
 707     bind $pn <B1-Enter> panel_cancel_repeat
 708
 709     if $setup(b2_marks) {
 710         bind $pn <Button-2> "
 711             $panel_cmd mdown 1  \[%W index @%x,%y]"
 712
 713         bind $pn <ButtonRelease-2> "
 714             $panel_cmd mup 1    \[%W index @%x,%y]
 715             panel_cancel_repeat
 716         "
 717
 718         bind $pn <B2-Motion> "
 719             set mc_x %x
 720             set mc_y %y
 721             $panel_cmd motion 1 \[%W index @%x,%y]
 722         "
 723
 724         bind $pn <B2-Leave> "
 725             set mc_x %x
 726             set mc_y %y
 727             panel_drag %W $panel_cmd 1
 728         "
 729     } else {
 730         # We have blt
 731 #       blt_drag&drop source $pn config -button 2 -packagecmd drag_test \
 732 #               -selftarget 1
 733 #       blt_drag&drop source $pn handler text dd_send_file
 734     }
 735
 736     # Menu popup.
 737     bind $pn <Button-3> "
 738         $panel_cmd mdown 2 \[%W index @%x,%y]
 739         catch {destroy .m}
 740         menu .m -tearoff 0
 741         $panel_cmd load \[%W index @%x,%y] %X %Y
 742         #Buggy Tk8.0
 743         catch {tk_popup .m %X %Y}
 744     "
 745
 746     bind $pn <B2-Enter> panel_cancel_repeat
 747
 748     $the_panel.m.scroll configure \
 749         -command "panel_scroll $pn $panel_cmd"
 750     $the_panel.m.p.scroll configure \
 751         -command "$pn xview"
 752     panel_conf $pn $panel_cmd
 753 }
 754
 755 proc panel_info {item} {
 756     global setup
 757
 758     return $setup($item)
 759 }
 760
 761 proc panel_mark {tag panel n} {
 762     config_colors $panel
 763     $panel tag add $tag "${n}.0" "${n}.0 lineend"
 764 }
 765
 766 # op is add or remove
 767 proc panel_mark_entry {win op line} {
 768     $win.m.p.panel tag $op marked $line.0 "$line.0 lineend"
 769 }
 770
 771 proc panel_unmark_entry {win line} {
 772     $win.m.p.panel tag remove selected $line.0 "$line.0 lineend"
 773 }
 774
 775 #
 776 # Misc routines
 777 #
 778
 779 # Configure the panel tags
 780 proc config_colors {which} {
 781     global setup
 782
 783     # se -- selected file
 784     $which tag configure selected -back $setup(panelcolor,selected_back)
 785
 786     foreach v {marked directory executable regular selected} {
 787         $which tag configure $v -fore $setup(panelcolor,$v)
 788     }
 789     $which tag configure directory -font $setup(paneldir)
 790
 791     $which tag raise marked
 792 }
 793
 794 proc tclerror {msg} {
 795  puts stderr "TkError: [$msg]\n\r"
 796 }
 797
 798 #
 799 # FIXME: This is not finished, have to deal with activefore, activeback
 800 # highlight{fore,back}
 801 #
 802 proc error_colors {wins} {
 803     global setup
 804
 805     foreach widget $wins {
 806         catch "$widget configure -foreground $setup(errorfore)"
 807         catch "$widget configure -background $setup(errorback)"
 808     }
 809 }
 810
 811 #
 812 #
 813 # Layout routines
 814 #
 815 #
 816 proc layout_midnight {} {
 817     global one_window
 818     global wlist
 819
 820     #puts $wlist
 821     #
 822     # we want to make the prompt and the input line sunken
 823     # so we sunk the frame, and set a borderwidth for it
 824     # while removing the sunken attribute set by the newinput
 825     .p.i0 configure -relief flat
 826     .p configure -relief sunken -borderwidth 2
 827     pack .p.l5 -side left
 828     pack .p.i0 -side left -expand 1 -fill x -anchor e
 829     pack .n4 -side bottom -fill x
 830     pack .p -side bottom -fill x
 831
 832     if $one_window {
 833         pack .left -side top -side left -fill both -expand 1
 834         pack .right -side top -side right -fill both -expand 1
 835     }
 836 }
 837
 838 proc layout_query {} {
 839     global wlist
 840
 841 #    puts "$wlist"
 842     set t [llength $wlist]
 843     if {$t == 2} {
 844         pack .query.l1 -side top -pady 2m -padx 2m
 845         pack .query.b0 -side right  -ipadx 2m -padx 4m -pady 2m -expand 1
 846     } else {
 847         pack .query.l1  -side top -pady 2m -padx 2m
 848
 849         for {set b 2} {$b != 1} {incr b} {
 850             if {$b == $t} {
 851                 set b 0
 852             }
 853             pack .query.b$b -side right -ipadx 2m -padx 4m -pady 2m -expand 1
 854         }
 855     }
 856 }
 857
 858 proc layout_listbox {} {
 859     scrollbar .listbox.s -width 3m -command {.listbox.x0 yview}
 860     .listbox.x0 configure -yscroll {.listbox.s set}
 861     pack .listbox.s -fill y -side right
 862     pack .listbox.x0 -expand 1 -fill both -padx 4m -pady 4m -side left
 863 }
 864
 865 proc layout_quick_confirm {} {
 866     pack .quick_confirm.c.c1 .quick_confirm.c.c2 .quick_confirm.c.c3 \
 867         -side top -anchor w
 868     pack .quick_confirm.b.b0 .quick_confirm.b.b4 -side left -padx 4m -expand 1
 869
 870     pack .quick_confirm.c -side top -pady 4m
 871     pack .quick_confirm.b -side top -pady 2m
 872 }
 873
 874 proc layout_quick_file_mask {} {
 875     global wlist
 876 #    puts stderr "$wlist"
 877
 878     # We add some space
 879     .quick_file_mask configure -borderwidth 5m
 880
 881     pack .quick_file_mask.b.b1 .quick_file_mask.b.b2 \
 882         -side left -expand 1 -padx 4m
 883
 884     pack .quick_file_mask.l3  -side top -anchor w -expand 1
 885     pack .quick_file_mask.s.i5 -fill x -expand 1 -anchor w
 886     pack .quick_file_mask.s.c6 -anchor e -padx 4m -pady 1m
 887     pack .quick_file_mask.s -expand 1 -fill x -side top
 888
 889     pack .quick_file_mask.d.l7 -pady 4m
 890     pack .quick_file_mask.d -side top -anchor w
 891     pack .quick_file_mask.i4 -expand 1 -fill x -side top
 892
 893     pack .quick_file_mask.t.c8 .quick_file_mask.t.c0 -side top -anchor e
 894     catch {pack .quick_file_mask.t.c9 -side top -anchor e}
 895
 896     pack .quick_file_mask.t -side top -anchor e
 897     frame .quick_file_mask.space -height 4m
 898     pack .quick_file_mask.space -side top
 899     pack .quick_file_mask.b -fill x -expand 1 -side top
 900 }
 901
 902 proc layout_quick_vfs {} {
 903     global wlist
 904 #    puts stderr "$wlist"
 905     pack .quick_vfs.t.l1 -side left
 906     pack .quick_vfs.t.i2 -side left -expand 1 -fill x -padx 2m
 907     pack .quick_vfs.t.l3 -side left
 908
 909     pack .quick_vfs.l.l4 -side top -anchor w
 910     pack .quick_vfs.l.r5 -side left -anchor w
 911     pack .quick_vfs.l.i6 -side right -anchor se
 912     pack .quick_vfs.b.b7 .quick_vfs.b.b0 -padx 4m -side left -expand 1
 913
 914     pack .quick_vfs.t -side top -expand 1 -fill x -pady 4m -padx 4m
 915     pack .quick_vfs.l -side top -expand 1 -fill x -padx 4m
 916     pack .quick_vfs.b -side top -expand 1 -fill x -padx 4m -pady 4m
 917 }
 918
 919 proc layout_dbits {} {
 920     pack .dbits.r1 -anchor w -padx 4m -pady 4m -side top
 921     pack .dbits.b0 -side top
 922 }
 923
 924 proc layout_chown {} {
 925     global setup
 926
 927     pack .chown.b.b8 .chown.b.b0 -side left -padx 4m -expand 1
 928
 929     # May be invoked with different number of buttons
 930     # There is already a problem: the cancel button is
 931     # not close to the ok button, I will have to look into this.
 932     catch {
 933         pack .chown.b.b9 .chown.b.b10 .chown.b.b11 \
 934             -side left -padx 4m -expand 1
 935     }
 936     label .chown.l.fname -text {File name}
 937     label .chown.l.owner -text {Owner name}
 938     label .chown.l.group -text {Group name}
 939     label .chown.l.size -text {Size}
 940     label .chown.l.perm -text {Permission}
 941
 942     pack \
 943         .chown.l.fname .chown.l.l7 \
 944         .chown.l.owner .chown.l.l6 \
 945         .chown.l.group .chown.l.l5 \
 946         .chown.l.size  .chown.l.l4 \
 947         .chown.l.perm  .chown.l.l3 -side top -anchor w -padx 2m
 948
 949     foreach i {l3 l4 l5 l6 l7} {
 950         .chown.l.$i configure -fore $setup(high)
 951     }
 952     pack .chown.l.l3 .chown.l.l4 .chown.l.l5 .chown.l.l6 .chown.l.l7 \
 953         -side top -pady 1m -padx 4m -anchor w
 954
 955     # Configure the listboxes
 956     scrollbar .chown.f.s -width 3m -command {.chown.f.x2 yview}
 957     .chown.f.x2 configure -yscroll {.chown.f.s set}
 958     label .chown.f.l -text {Group name}
 959     pack .chown.f.l -side top -anchor w
 960     pack .chown.f.x2 -side left -fill y -expand 1
 961     pack .chown.f.s -side right -fill y -expand 1
 962
 963     scrollbar .chown.g.s -width 3m -command {.chown.g.x1 yview}
 964     .chown.g.x1 configure -yscroll {.chown.g.s set}
 965     label .chown.g.l -text {User name}
 966     pack .chown.g.l -side top -anchor w
 967     pack .chown.g.x1 -side left -fill y -expand 1
 968     pack .chown.g.s -side right -fill y -expand 1
 969
 970     .chown.b configure -relief sunken
 971     pack .chown.b -side bottom -pady 4m -fill x
 972     pack .chown.g .chown.f -side left -padx 4m -pady 4m -expand 1 -fill y
 973     pack .chown.l -side right -padx 4m
 974 }
 975
 976 proc layout_chmod {} {
 977     global wlist
 978 #    puts stderr "$wlist \n\r"
 979     pack .chmod.c.c5 .chmod.c.c6 .chmod.c.c7 .chmod.c.c8 .chmod.c.c9 \
 980         .chmod.c.c10 \
 981         .chmod.c.c11 .chmod.c.c12 .chmod.c.c13 .chmod.c.c14 .chmod.c.c15 \
 982         .chmod.c.c16 -side top -anchor w
 983
 984     pack .chmod.b.b17 .chmod.b.b0 -side left -padx 4m -pady 4m -side left
 985     catch {
 986         pack .chmod.b.b18 .chmod.b.b19 .chmod.b.b19 .chmod.b.b20 \
 987             .chmod.b.b21 -side left -padx 4m -pady 4m -side left
 988     }
 989
 990     label .chmod.l.msg -text {Use "t" or Insert to\nmark attributes}
 991     label .chmod.l.fname -text {Name}
 992     label .chmod.l.perm   -text {Permission (octal)}
 993     label .chmod.l.owner  -text {Owner name}
 994     label .chmod.l.group  -text {Group name}
 995
 996     pack \
 997         .chmod.l.fname .chmod.l.l4 \
 998         .chmod.l.perm  .chmod.l.l1 \
 999         .chmod.l.owner .chmod.l.l3 \
1000         .chmod.l.group .chmod.l.l2 .chmod.l.msg -side top -anchor w -padx 2m
1001     pack .chmod.b -side bottom
1002     pack .chmod.l -side right -padx 4m -anchor n -pady 4m
1003     pack .chmod.c -side left -padx 4m -pady 4m
1004 }
1005
1006 proc layout_view {} {
1007     global wlist
1008
1009     pack [lindex $wlist 0] -side bottom -fill x
1010     pack [lindex $wlist 1] -side top -expand 1 -fill both
1011 }
1012
1013 proc layout_replace {} {
1014     global wlist
1015
1016     error_colors "$wlist .replace"
1017
1018     set alist {}
1019     set plist {}
1020     set ilist {}
1021
1022     foreach a $wlist {
1023         if [regexp ^.replace.p.l $a] {
1024             set plabel $a
1025         } elseif [regexp ^.replace.p $a] {
1026             set plist "$plist $a"
1027         } elseif [regexp ^.replace.a.l $a] {
1028             set alabel $a
1029         } elseif [regexp ^.replace.a $a] {
1030             set alist "$alist $a"
1031         } elseif [regexp ^.replace.i $a] {
1032             set ilist "$ilist $a"
1033         } elseif [regexp ^.replace.b $a] {
1034             set abortbutton $a
1035         } else {
1036             set fname $a
1037         }
1038     }
1039
1040 #    puts stderr "$wlist\n\r"
1041 #    puts stderr "alist: $alist\n\rplist: $plist\n\rilist: $ilist\n\r"
1042 #    puts stderr "plabel: $plabel\n\rfname: $fname"
1043
1044     pack $fname -side top -fill x -anchor w -pady 6m -padx 12m
1045     pack $abortbutton -side bottom -anchor e -padx 8m -pady 4m
1046
1047     eval pack $ilist -side top -anchor w
1048     pack .replace.i -padx 10m -pady 2m -anchor w
1049
1050     pack $plabel -side left -anchor w -padx 10m
1051     eval pack $plist -side left -anchor e -fill x
1052     pack .replace.p -side top -fill x -padx 10m
1053
1054     pack $alabel -side left -anchor w -padx 10m
1055     eval pack $alist -side left -anchor e -fill x
1056     pack .replace.a -side top -fill x  -padx 10m
1057 }
1058
1059 proc layout_complete {} {
1060     global wlist
1061
1062     eval pack $wlist -side top
1063 }
1064
1065 proc layout_opwin {} {
1066     global wlist
1067     global setup
1068
1069     pack .opwin.b.b0 .opwin.b.b14 -side left -expand 1
1070     pack .opwin.f0.l1 .opwin.f0.l2 -side left -anchor w
1071     pack .opwin.f1.l3 .opwin.f1.l4 -side left -anchor w
1072
1073     foreach a {.opwin.2.l11 .opwin.1.l8 .opwin.0.l5} {
1074         $a configure -width 8
1075     }
1076     pack .opwin.2.l11 .opwin.2.g13 -side left -fill x
1077     pack .opwin.1.l8 .opwin.1.g10  -side left -fill x
1078     pack .opwin.0.l5 .opwin.0.l6  -side left -fill x
1079
1080     pack .opwin.b -side bottom -pady 4m -fill x
1081     pack .opwin.f0 -side top -padx 10m -anchor w
1082     pack .opwin.f1 -side top -padx 10m -pady 4m -anchor w
1083     pack .opwin.0 .opwin.1 .opwin.2 -side top -padx 4m
1084 }
1085
1086 proc dummy_layout {name} {
1087     eval "proc layout_$name {} {
1088           global wlist
1089 #          puts stderr \"\$wlist \\n\"
1090           eval pack \$wlist -side top}"
1091 }
1092 #
1093 # the achown commands will have to be rewriten
1094 # to use only widgets and no writing callbacks.
1095 #
1096
1097 foreach i {
1098     achown tree
1099     } {
1100         dummy_layout $i
1101     }
1102
1103 proc layout_quick_input {} {
1104     global wlist
1105
1106 #    puts stderr "$wlist \n\r"
1107     .quick_input.i1 configure -width 60
1108     label .quick_input.dummy
1109     pack .quick_input.b.b2 .quick_input.b.b3 -side left -padx 4m -expand 1
1110     pack .quick_input.b -side bottom -pady 4m
1111     pack .quick_input.dummy -side top
1112     pack .quick_input.l0 -side top -expand 1 -ipadx 2m -ipady 2m
1113     pack .quick_input.i1 -side bottom -fill x -padx 4m
1114 }
1115
1116 proc create_drop_target {name icon} {
1117     toplevel .drop-$name
1118
1119     button .drop-$name.b -text "Drop target"
1120     pack .drop-$name.b
1121     wm group .drop-$name .
1122     wm overrideredirect .drop-$name 1
1123     wm withdraw .drop-$name
1124     wm deiconify .drop-$name
1125     wm geometry .drop-$name +0+0
1126 #    blt_drag&drop target .drop-$name.b handler file mc_drag_target
1127 #    blt_drag&drop target .drop-$name.b handler text mc_drag_target
1128 }
1129
1130 #
1131 # Creates the container
1132 #
1133 proc create_container {container} {
1134     canvas $container
1135     pack $container -fill both -expand 1
1136 }
1137
1138 #
1139 # Removes all of the widgets in a container (.left or .right)
1140 #
1141 proc container_clean {container} {
1142     set widgets [winfo children $container]
1143
1144     foreach widget $widgets {
1145         destroy $widget
1146     }
1147 }
1148
1149 #
1150 # Setups the binding called after the layout procedure
1151 #
1152 proc bind_setup {win} {
1153     flush stderr
1154     bindtags $win {all $win}
1155     wm protocol $win WM_DELETE_WINDOW "tkmc e scape"
1156     bind $win <Leave>
1157 }
1158
1159 proc keyboard_bindings {} {
1160     # Remove the Tab binding.
1161     bind all <Tab> {}
1162
1163     bind all <KeyPress>          "tkmc r %A"
1164
1165     # Remove the Alt-key binding and put a sensible one instead
1166     bind all <Alt-KeyPress>      "tkmc a %A"
1167     bind all <Control-KeyPress> "tkmc c %A"
1168     bind all <Meta-KeyPress>    "tkmc a %A"
1169
1170     foreach i {Left Right Up Down End R13 Home F27 F29 Prior \
1171                Next F35 Return KP_Enter Delete Insert BackSpace \
1172                F1 F2 F3 F4 F5 F6 F7 F8 F9 F10} {
1173         bind all <Key-$i> "tkmc k %K"
1174     }
1175 }
1176
1177 # Centers a window based on .
1178 proc center_win {win} {
1179     global center_toplevels
1180
1181     wm transient $win [winfo toplevel [winfo parent $win]]
1182
1183     wm withdraw $win
1184     update idletasks
1185
1186     if {$center_toplevels} {
1187         set ch [winfo reqheight $win]
1188         set cw [winfo reqwidth $win]
1189
1190         set geo [split [wm geometry .] +x]
1191         set pw [lindex $geo 0]
1192         set ph [lindex $geo 1]
1193         set px [lindex $geo 2]
1194         set py [lindex $geo 3]
1195
1196         set x [expr $px+(($pw-$cw)/2)]
1197         set y [expr $py+(($ph-$ch)/2)]
1198
1199         wm geometry $win +$x+$y
1200     }
1201     wm deiconify $win
1202     grab $win
1203     tkwait visibility $win
1204 }
1205
1206 #
1207 # Busy window handling
1208 #
1209 proc win_busy {w} {
1210     $w configure -cursor watch
1211 }
1212
1213
1214 #
1215 # Color configurations
1216 #
1217 proc tk_colors {} {
1218 }
1219
1220 proc color_model {} {
1221 }
1222
1223 # gray85 is the background for the new tk4
1224 proc gray_colors {base} {
1225     global setup
1226     global have_blt
1227
1228 #
1229 #    set setup(def_back) [tkDarken $base 90]
1230 #    set setup(def_fore) black
1231 #    set setup(selected) [tkDarken $base 110]
1232 #    set setup(marked)   SlateBlue
1233 #    set setup(high)     $setup(def_back)
1234
1235     if {0} {
1236         set dark_color [tkDarken $base 90]
1237         set setup(def_back) [tkDarken $base 110]
1238         set setup(selected) NavyBlue
1239         set setup(selected_fg) white
1240     } else {
1241         set dark_color $base
1242         set setup(def_back) #d9d9d9
1243         set setup(selected) white
1244         set setup(selected_fg) black
1245     }
1246     set setup(def_fore) black
1247     set setup(high)     yellow
1248
1249 #
1250 # Panel colors:
1251 #
1252     # Marked files
1253     set setup(panelcolor,marked)        yellow
1254     set setup(panelcolor,directory)     blue
1255     set setup(panelcolor,executable)    red
1256     set setup(panelcolor,regular)       black
1257     set setup(panelcolor,selected_back) white
1258     set setup(panelcolor,selected)      black
1259
1260 # Viewer colors
1261
1262     set setup(view_bold)      "-fore yellow -back $dark_color"
1263     set setup(view_underline) "-fore red    -back $dark_color"
1264     set setup(view_mark)      "-fore cyan   -back $dark_color"
1265     set setup(view_normal)    "-fore black  -back $dark_color"
1266
1267 # The percentage bars on info:
1268     set setup(percolor) "blue"
1269
1270 # The sort bar colors
1271     set setup(sort_fg) $setup(def_fore)
1272     set setup(sort_bg) $setup(def_back)
1273     set setup(with_sortbar) 1
1274
1275     # We use BLT only for drag and drop, if this is not available,
1276     # then we use the 2nd button for regular file marking.
1277     set have_blt 0
1278     if $have_blt {
1279         set setup(b2_marks) 0
1280     } else {
1281         set setup(b2_marks) 1
1282     }
1283
1284 # The errors
1285     set setup(errorfore) white
1286     set setup(errorback) red
1287
1288 }
1289
1290 proc bisque_colors {} {
1291     global setup
1292
1293     set setup(def_back) bisque3
1294     set setup(def_fore) black
1295     set setup(selected) bisque2
1296     set setup(marked)   SlateBlue
1297     set setup(high)     gray
1298 }
1299
1300 proc sanity_check {} {
1301     if [catch {bindtags .}] {
1302         puts stderr "The Midnight Commander requires Tk 4.0 beta 3 or 4\n\r"
1303         puts stderr "You can get it from: ftp://ftp.smli.com/pub/tcl"
1304         exit 1
1305     }
1306 }
1307
1308 #sanity_check
1309
1310 # Until I figure out how to remove specific bindings from a widget
1311 # I remove all of the classes bindings.
1312
1313 #bind Text <Enter> {}
1314 #bind Text <FocusIn> {}
1315
1316 # bind Entry <Enter> {}
1317 # bind Entry <FocusIn> {}
1318
1319 keyboard_bindings
1320
1321 set setup(tearoff) 0
1322 set setup(action_foreground) blue
1323 set setup(lines) 24
1324 set setup(cols)  40
1325 set setup(with_icons) 0
1326 set setup(widthc) 0
1327 set setup(heightc) 0
1328 set setup(real_width) 0
1329
1330 # Determine Tk version
1331 set beta_4 ![catch tk_bisque]
1332 if $beta_4 {
1333     tk_setPalette gray85
1334     gray_colors gray70
1335 } else {
1336     bisque_colors
1337 }
1338
1339 ## Some globals
1340 set mc_repeat {}
1341 set mc_x 0
1342 set mc_y 0
1343 set center_toplevels 1
1344 #set center_toplevels 0
1345
1346 # button .testbutton [lindex [.testbutton configure -font] 3]
1347 #set setup(panelfont) lucidasanstypewriter-bold-14
1348 set setup(panelfont) lucidasanstypewriter-14
1349 set setup(paneldir)  lucidasanstypewriter-bold-14
1350 set setup(font)  "-*-helvetica-medium-r-normal-*-14-*-*-*-*-*-*-*"
1351
1352 #
1353 #
1354 # This variable if set, will make the program load gui.*.tcl files
1355 # instead of the gui.tcl file created during instalaltion.
1356 set use_separate_gui_files 0
1357
1358 if [file exist ~/.mc/tkmc] {source ~/.mc/tkmc}
1359
1360 catch {
1361 #    option add *font $setup(font) userDefault
1362 #    option add *Menu*activeBackground NavyBlue
1363 #    option add *Menu*activeForeground white
1364 #    option add *Menubutton*activeBackground NavyBlue
1365 #    option add *Menubutton*activeForeground white
1366 #    option add *Button*activeBackground NavyBlue
1367 #    option add *Button*activeForeground white
1368 ##    set setup(panelfont) $setup(font)
1369 }
1370
1371 proc run_gui_design {root} {
1372     global components
1373
1374     create_workspace $root
1375     gui_design $root $components
1376 }
1377
1378 source $LIBDIR/gd.tcl
1379
1380 set tk_strictMotif 1
1381 create_top_menu
1382
1383 create_drop_target Hola Zonzo