mirror of https://github.com/MidnightCommander/mc
1384 lines
36 KiB
Tcl
1384 lines
36 KiB
Tcl
|
# Midnight Commander Tk code.
|
||
|
|
# Copyright (C) 1995, 1996, 1997 Miguel de Icaza
|
||
|
|
#
|
||
|
|
#
|
||
|
|
# Todo:
|
||
|
|
# Fix the internal viewer
|
||
|
|
# Missing commands: mc_file_info, mc_open_with
|
||
|
|
# The default buttons have a problem with the new frame around them:
|
||
|
|
# they don't display the focus.
|
||
|
|
#
|
||
|
|
# This program is free software; you can redistribute it and/or modify
|
||
|
|
# it under the terms of the GNU General Public License as published by
|
||
|
|
# the Free Software Foundation; either version 2 of the License, or
|
||
|
|
# (at your option) any later version.
|
||
|
|
#
|
||
|
|
# This program is distributed in the hope that it will be useful,
|
||
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
# GNU General Public License for more details.
|
||
|
|
#
|
||
|
|
# You should have received a copy of the GNU General Public License
|
||
|
|
# along with this program; if not, write to the Free Software
|
||
|
|
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
|
||
|
|
|
||
|
|
wm iconname . tkmc
|
||
|
|
wm title . "Midnight Commander (TK edition)"
|
||
|
|
|
||
|
|
#
|
||
|
|
# Menu routines
|
||
|
|
#
|
||
|
|
proc create_top_menu {} {
|
||
|
|
global top_menus
|
||
|
|
global setup
|
||
|
|
set top_menus ""
|
||
|
|
|
||
|
|
frame .mbar -relief raised -bd 2
|
||
|
|
|
||
|
|
pack .mbar -side top -fill x
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Widget: WMenu
|
||
|
|
#
|
||
|
|
proc create_menu {str topmenu} {
|
||
|
|
global top_menus
|
||
|
|
global setup
|
||
|
|
|
||
|
|
menubutton .mbar.$topmenu -text $str -underline 0 -menu .mbar.$topmenu.menu
|
||
|
|
pack .mbar.$topmenu -side left
|
||
|
|
menu .mbar.$topmenu.menu -tearoff $setup(tearoff)
|
||
|
|
set top_menus "$top_menus $topmenu"
|
||
|
|
}
|
||
|
|
|
||
|
|
proc create_mentry {topmenu entry cmd idx} {
|
||
|
|
.mbar.$topmenu.menu add command -label "$entry" -command "$cmd $idx"
|
||
|
|
}
|
||
|
|
|
||
|
|
proc add_separator {topmenu} {
|
||
|
|
.mbar.$topmenu.menu add separator
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Widget: WButton
|
||
|
|
#
|
||
|
|
proc newbutton {name cmd text isdef} {
|
||
|
|
if $isdef {
|
||
|
|
frame $name -relief sunken -bd 1
|
||
|
|
set name "$name.button"
|
||
|
|
}
|
||
|
|
button $name -text "$text" -command $cmd -justify left
|
||
|
|
if $isdef {
|
||
|
|
pack $name -padx 1m -pady 1m
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Widget: WGauge
|
||
|
|
#
|
||
|
|
proc newgauge {win} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
canvas $win -height $setup(heightc) -width 250 -relief sunken -border 2
|
||
|
|
$win create rectangle 0 0 0 0 -tags gauge -fill black -stipple gray50
|
||
|
|
|
||
|
|
# So that we can tell the C code, which is the gauge size currently
|
||
|
|
bind $win <Configure> "x$win %w"
|
||
|
|
}
|
||
|
|
|
||
|
|
# Used to show the gauge information
|
||
|
|
proc gauge_shown {win} {
|
||
|
|
# $win configure -relief sunken -border 2
|
||
|
|
}
|
||
|
|
|
||
|
|
# Used to hide the gauge information.
|
||
|
|
proc gauge_hidden {win} {
|
||
|
|
# $win configure -relief flat -border 0
|
||
|
|
$win coords gauge 0 0 0 0
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Widget: WView
|
||
|
|
#
|
||
|
|
proc view_size {cmd w h} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
$cmd dim [expr $w/$setup(widthc)] [expr $h/$setup(heightc)]
|
||
|
|
}
|
||
|
|
|
||
|
|
proc newview {is_panel container winname cmd} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
# FIXME: The trick to get the window without too much
|
||
|
|
# movement/flicker is to use an extra frame, and use the placer
|
||
|
|
# like it was done in WInfo.
|
||
|
|
if $is_panel {
|
||
|
|
set width [expr [winfo width $container]/$setup(widthc)]
|
||
|
|
set height [expr [winfo height $container]/$setup(heightc)]
|
||
|
|
}
|
||
|
|
|
||
|
|
frame $winname
|
||
|
|
frame $winname.v
|
||
|
|
frame $winname.v.status
|
||
|
|
eval text $winname.v.view $setup(view_normal) -font $setup(panelfont)
|
||
|
|
|
||
|
|
# Create the tag names for the viewer attributes
|
||
|
|
eval $winname.v.view tag configure bold $setup(view_bold)
|
||
|
|
eval $winname.v.view tag configure underline $setup(view_underline)
|
||
|
|
eval $winname.v.view tag configure mark $setup(view_mark)
|
||
|
|
eval $winname.v.view tag configure normal $setup(view_normal)
|
||
|
|
|
||
|
|
# Make the status fields
|
||
|
|
label $winname.v.status.filename
|
||
|
|
label $winname.v.status.column
|
||
|
|
label $winname.v.status.size
|
||
|
|
label $winname.v.status.flags
|
||
|
|
|
||
|
|
pack $winname.v.status.filename -side left
|
||
|
|
pack $winname.v.status.column -anchor w -side left -fill x -expand 1
|
||
|
|
pack $winname.v.status.size -anchor w -side left -fill x -expand 1
|
||
|
|
pack $winname.v.status.flags -anchor w -side left -fill x -expand 1
|
||
|
|
|
||
|
|
# Pack the main components
|
||
|
|
pack $winname.v.status -side top -fill x
|
||
|
|
pack $winname.v.view -side bottom -expand 1 -fill both
|
||
|
|
pack $winname.v -expand 1 -fill both
|
||
|
|
|
||
|
|
bindtags $winname.v.view "all . $winname.v.view"
|
||
|
|
bind $winname.v.view <Configure> "view_size $cmd %w %h"
|
||
|
|
|
||
|
|
if $is_panel {
|
||
|
|
$winname.v.view configure -width $width -height $height
|
||
|
|
pack $winname
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc view_update_info {win fname col size flags} {
|
||
|
|
$win.v.status.filename configure -text "File: $fname"
|
||
|
|
$win.v.status.column configure -text "Column: $col"
|
||
|
|
$win.v.status.size configure -text "$size bytes"
|
||
|
|
$win.v.status.flags configure -text "$flags"
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Hack: remove all the text on the window and then insert
|
||
|
|
# new lines. Maybe the newlines
|
||
|
|
proc cleanview {win} {
|
||
|
|
$win delete 1.0 end
|
||
|
|
$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"
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Widget: WRadio
|
||
|
|
#
|
||
|
|
proc newradio {name} {
|
||
|
|
frame $name
|
||
|
|
global last_radio
|
||
|
|
set last_radio $name
|
||
|
|
}
|
||
|
|
|
||
|
|
proc radio_item {idx text cmd act} {
|
||
|
|
global last_radio
|
||
|
|
radiobutton $last_radio.$idx -text "$text" -variable v$last_radio -value $idx -command "$cmd select $idx"
|
||
|
|
if $act {
|
||
|
|
$last_radio.$idx select
|
||
|
|
}
|
||
|
|
pack $last_radio.$idx -side top -anchor w
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Widget: Input
|
||
|
|
#
|
||
|
|
#
|
||
|
|
|
||
|
|
proc entry_save_sel {win} {
|
||
|
|
global sel
|
||
|
|
|
||
|
|
if [$win selection present] {
|
||
|
|
set sel(pres) 1
|
||
|
|
set sel(first) [$win index sel.first]
|
||
|
|
set sel(last) [$win index sel.last]
|
||
|
|
} else {
|
||
|
|
set sel(pres) 0
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc entry_restore_sel {win} {
|
||
|
|
global sel
|
||
|
|
|
||
|
|
if $sel(pres) {
|
||
|
|
$win selection from $sel(first)
|
||
|
|
$win selection to $sel(last)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc entry_click {win x} {
|
||
|
|
global sel
|
||
|
|
set p [$win index @$x]
|
||
|
|
x$win mouse $p
|
||
|
|
x$win setmark
|
||
|
|
set sel(from) $p
|
||
|
|
}
|
||
|
|
|
||
|
|
proc entry_move {win x} {
|
||
|
|
global sel
|
||
|
|
set p [$win index @$x]
|
||
|
|
$win selection from $sel(from)
|
||
|
|
$win selection to $p
|
||
|
|
x$win mouse $p
|
||
|
|
}
|
||
|
|
|
||
|
|
proc bind_entry {win} {
|
||
|
|
bind $win <1> "entry_click $win %x"
|
||
|
|
bind $win <B1-Motion> "entry_move $win %x"
|
||
|
|
}
|
||
|
|
|
||
|
|
proc newinput {name text} {
|
||
|
|
entry $name -relief sunken -background white -foreground black
|
||
|
|
$name insert 0 "$text"
|
||
|
|
bindtags $name "all . $name "
|
||
|
|
bind_entry $name
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Widget: WCheck
|
||
|
|
#
|
||
|
|
proc newcheck {name cmd text act} {
|
||
|
|
checkbutton $name -text "$text" -command "$cmd"
|
||
|
|
if $act { $name select }
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Widget: WInfo
|
||
|
|
#
|
||
|
|
# window is the container name and widget name: .left.o2
|
||
|
|
# container is the container name: .left
|
||
|
|
#
|
||
|
|
proc info_entry {win name text} {
|
||
|
|
frame $win.b.finfo.$name
|
||
|
|
label $win.b.finfo.$name.label -text "$text"
|
||
|
|
label $win.b.finfo.$name.info
|
||
|
|
grid $win.b.finfo.$name.label -row 0 -column 0 -sticky we
|
||
|
|
grid $win.b.finfo.$name.info -row 0 -column 1 -sticky w
|
||
|
|
grid columnconfigure $win.b.finfo.$name 0 -minsize 100
|
||
|
|
}
|
||
|
|
|
||
|
|
proc newinfo {container window version} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
set width [winfo width $container]
|
||
|
|
set height [winfo height $container]
|
||
|
|
|
||
|
|
frame $window -width $width -height $height \
|
||
|
|
-borderwidth [expr $setup(widthc)/2]
|
||
|
|
|
||
|
|
frame $window.b
|
||
|
|
frame $window.b.v
|
||
|
|
frame $window.b.finfo -relief groove -borderwidth 2
|
||
|
|
frame $window.b.fs -relief groove -borderwidth 2
|
||
|
|
|
||
|
|
label $window.b.v.version -text " The Midnight Commander $version " \
|
||
|
|
-relief groove
|
||
|
|
pack $window.b.v.version -fill x
|
||
|
|
|
||
|
|
info_entry $window fname "File:"
|
||
|
|
info_entry $window location "Location:"
|
||
|
|
info_entry $window mode "Mode:"
|
||
|
|
info_entry $window links "Links:"
|
||
|
|
info_entry $window owner "Owner:"
|
||
|
|
info_entry $window size "Size:"
|
||
|
|
info_entry $window created "Created:"
|
||
|
|
info_entry $window modified "Modified:"
|
||
|
|
info_entry $window access "Access:"
|
||
|
|
|
||
|
|
pack $window.b.finfo.fname \
|
||
|
|
$window.b.finfo.location $window.b.finfo.mode $window.b.finfo.links \
|
||
|
|
$window.b.finfo.owner $window.b.finfo.size $window.b.finfo.created \
|
||
|
|
$window.b.finfo.modified $window.b.finfo.access \
|
||
|
|
-side top -anchor w
|
||
|
|
|
||
|
|
label $window.b.fs.fsys
|
||
|
|
label $window.b.fs.dev
|
||
|
|
label $window.b.fs.type
|
||
|
|
|
||
|
|
frame $window.b.fs.free
|
||
|
|
label $window.b.fs.free.label
|
||
|
|
newcanvas $window.b.fs.free.canvas
|
||
|
|
|
||
|
|
pack $window.b.fs.free.label -side left
|
||
|
|
pack $window.b.fs.free.canvas -side left
|
||
|
|
|
||
|
|
frame $window.b.fs.freeino
|
||
|
|
label $window.b.fs.freeino.label
|
||
|
|
newcanvas $window.b.fs.freeino.canvas
|
||
|
|
pack $window.b.fs.freeino.label -side left
|
||
|
|
pack $window.b.fs.freeino.canvas -side left
|
||
|
|
|
||
|
|
pack $window.b.fs.fsys \
|
||
|
|
$window.b.fs.dev $window.b.fs.type \
|
||
|
|
$window.b.fs.free \
|
||
|
|
$window.b.fs.freeino -side top -anchor w -padx $setup(widthc)
|
||
|
|
|
||
|
|
pack $window.b.v -side top -anchor w -fill x -expand 1
|
||
|
|
|
||
|
|
pack $window.b.fs -side bottom -anchor w -fill x -expand 1
|
||
|
|
|
||
|
|
pack $window.b.finfo -side top -anchor w \
|
||
|
|
-fill x -expand 1
|
||
|
|
|
||
|
|
pack $window.b
|
||
|
|
|
||
|
|
pack $window -fill both -expand 1
|
||
|
|
# pack $window.b
|
||
|
|
place $window.b -in $window -relx 0 -rely 0 -relheight 1 -relwidth 1
|
||
|
|
}
|
||
|
|
|
||
|
|
proc info_bar {win percent} {
|
||
|
|
global setup
|
||
|
|
set w [winfo width $win]
|
||
|
|
set s [expr (100-$percent)*$w/100]
|
||
|
|
|
||
|
|
$win coords bar 0 0 $s 50
|
||
|
|
# puts stderr "Width: $w $s\n\r"
|
||
|
|
}
|
||
|
|
|
||
|
|
proc info_none {win} {
|
||
|
|
$win coords bar 0 0 0 0
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
proc newcanvas {win} {
|
||
|
|
global setup
|
||
|
|
canvas $win -height $setup(heightc) -relief sunken -border 2
|
||
|
|
$win create rectangle 0 0 0 0 -tags bar -fill black -stipple gray50
|
||
|
|
}
|
||
|
|
|
||
|
|
proc infotext {win text} {
|
||
|
|
$win configure -text $text
|
||
|
|
}
|
||
|
|
|
||
|
|
proc xinfotext {win text} {
|
||
|
|
$win.info configure -text $text
|
||
|
|
}
|
||
|
|
# w containes the window name *and* the .b frame (like: .left.o2.b)
|
||
|
|
# FIXME: We should also display the rdev information
|
||
|
|
proc info_update {w
|
||
|
|
fname dev ino
|
||
|
|
mode mode_oct
|
||
|
|
links owner group
|
||
|
|
have_blocks blocks
|
||
|
|
size
|
||
|
|
have_rdev rdev rdev2
|
||
|
|
create modify access
|
||
|
|
fsys dev type
|
||
|
|
have_space avail percent total
|
||
|
|
have_ino nfree inoperc inotot} {
|
||
|
|
|
||
|
|
#
|
||
|
|
# Set all the text information
|
||
|
|
#
|
||
|
|
xinfotext $w.finfo.fname "$fname"
|
||
|
|
xinfotext $w.finfo.location "${dev}h:${ino}h"
|
||
|
|
xinfotext $w.finfo.mode "$mode ($mode_oct)"
|
||
|
|
xinfotext $w.finfo.links "$links"
|
||
|
|
xinfotext $w.finfo.owner "$owner/$group"
|
||
|
|
if $have_blocks {
|
||
|
|
xinfotext $w.finfo.size "$size ($blocks blocks)"
|
||
|
|
} else {
|
||
|
|
xinfotext $w.finfo.size "$size"
|
||
|
|
}
|
||
|
|
xinfotext $w.finfo.created "$create"
|
||
|
|
xinfotext $w.finfo.modified "$modify"
|
||
|
|
xinfotext $w.finfo.access "$access"
|
||
|
|
|
||
|
|
infotext $w.fs.fsys "Filesystem:\t$fsys"
|
||
|
|
infotext $w.fs.dev "Device:\t\t$dev"
|
||
|
|
infotext $w.fs.type "Type:\t\t$type"
|
||
|
|
if $have_space {
|
||
|
|
infotext $w.fs.free.label \
|
||
|
|
"Free Space $avail ($percent%) of $total"
|
||
|
|
info_bar $w.fs.free.canvas $percent
|
||
|
|
} else {
|
||
|
|
infotext $w.fs.free.label "No space information"
|
||
|
|
info_none $w.fs.free.canvas
|
||
|
|
}
|
||
|
|
if $have_ino {
|
||
|
|
infotext $w.fs.freeino.label \
|
||
|
|
"Free inodes $nfree ($inoperc%) of $inotot"
|
||
|
|
info_bar $w.fs.freeino.canvas $inoperc
|
||
|
|
} else {
|
||
|
|
infotext $w.fs.freeino.label "No inode information"
|
||
|
|
info_none $w.fs.freeino.canvas
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Widget: listbox
|
||
|
|
#
|
||
|
|
proc listbox_sel {win item} {
|
||
|
|
$win selection clear 0 end
|
||
|
|
$win selection set $item
|
||
|
|
$win see $item
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Widget: WPanel
|
||
|
|
#
|
||
|
|
proc panel_select {w pos cback} {
|
||
|
|
$w.m.p.panel tag add selected $pos.0 "$pos.0 lineend"
|
||
|
|
$w.m.p.panel see $pos.0
|
||
|
|
$cback top [$w.m.p.panel index @0,0]
|
||
|
|
}
|
||
|
|
|
||
|
|
proc panel_scroll {win cback args} {
|
||
|
|
eval "$win yview $args"
|
||
|
|
$cback top [$win index @0,0]
|
||
|
|
}
|
||
|
|
|
||
|
|
proc cmd_sort_add {name menu cmd} {
|
||
|
|
$menu add command -label $name -command "$cmd sort $name"
|
||
|
|
}
|
||
|
|
|
||
|
|
proc panel_setup {which cmd} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
frame $which
|
||
|
|
set m $which.cwd.menu
|
||
|
|
menubutton $which.cwd -text "loading..." -bd 1 -relief raised \
|
||
|
|
-menu $m -indicatoron 0
|
||
|
|
menu $m -tearoff 0
|
||
|
|
menu [set mm $m.sort] -tearoff 0
|
||
|
|
$m add command -label "Reverse sort order" -command "$cmd reverse"
|
||
|
|
$m add cascade -label "Sort" -menu $mm
|
||
|
|
cmd_sort_add "Name" $mm $cmd
|
||
|
|
cmd_sort_add "Extension" $mm $cmd
|
||
|
|
cmd_sort_add "Size" $mm $cmd
|
||
|
|
cmd_sort_add "Modify Time" $mm $cmd
|
||
|
|
cmd_sort_add "Access Time" $mm $cmd
|
||
|
|
cmd_sort_add "Change Time" $mm $cmd
|
||
|
|
cmd_sort_add "Inode" $mm $cmd
|
||
|
|
cmd_sort_add "Type" $mm $cmd
|
||
|
|
cmd_sort_add "Links" $mm $cmd
|
||
|
|
cmd_sort_add "NGID" $mm $cmd
|
||
|
|
cmd_sort_add "NUID" $mm $cmd
|
||
|
|
cmd_sort_add "Owner" $mm $cmd
|
||
|
|
cmd_sort_add "Group" $mm $cmd
|
||
|
|
cmd_sort_add "Unsorted" $mm $cmd
|
||
|
|
|
||
|
|
$m add command -label "Refresh" -command "$cmd refresh"
|
||
|
|
$m add separator
|
||
|
|
$m add command -label "Set mask" -command "$cmd setmask"
|
||
|
|
$m add command -label "No mask" -command "$cmd nomask"
|
||
|
|
|
||
|
|
frame $which.m
|
||
|
|
label $which.mini
|
||
|
|
scrollbar $which.m.scroll -width 3m
|
||
|
|
|
||
|
|
frame $which.m.p -relief sunken -borderwidth 2
|
||
|
|
# The sort bar
|
||
|
|
if $setup(with_sortbar) {
|
||
|
|
canvas $which.m.p.types \
|
||
|
|
-borderwidth 0\
|
||
|
|
-back $setup(def_back) \
|
||
|
|
-highlightthickness 0 -height 0
|
||
|
|
pack $which.m.p.types -side top -fill x
|
||
|
|
}
|
||
|
|
|
||
|
|
scrollbar $which.m.p.scroll -width 3m -orient horizontal
|
||
|
|
|
||
|
|
# The file listing panel
|
||
|
|
text $which.m.p.panel -width $setup(cols) -yscroll "$which.m.scroll set" \
|
||
|
|
-fore $setup(def_fore) -back $setup(def_back) \
|
||
|
|
-wrap none -height $setup(lines) -font $setup(panelfont) \
|
||
|
|
-relief flat -borderwidth 0 -highlightthickness 0 \
|
||
|
|
-xscroll "$which.m.p.scroll set"
|
||
|
|
|
||
|
|
bindtags $which.m.p.panel "all . $which.m.p.panel"
|
||
|
|
|
||
|
|
proc x$which.m.p.panel {x} "$cmd \$x"
|
||
|
|
|
||
|
|
pack $which.m.p.panel -side top -fill both -expand 1
|
||
|
|
pack $which.m.p.scroll -side top -fill x
|
||
|
|
pack $which.m.p -side left -fill both -expand 1
|
||
|
|
|
||
|
|
pack $which.m.scroll -side right -fill y
|
||
|
|
pack $which.cwd -side top -anchor w
|
||
|
|
pack $which.m -side top -fill both -expand 1
|
||
|
|
pack $which.mini -side top -fill x
|
||
|
|
|
||
|
|
pack $which -fill both -expand 1
|
||
|
|
|
||
|
|
config_colors $which.m.p.panel
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Draging the panels:
|
||
|
|
# mc_x and mc_y contains the last positions where the mouse was
|
||
|
|
# mc_repeat contains the id of the after command.
|
||
|
|
#
|
||
|
|
proc panel_cancel_repeat {} {
|
||
|
|
global mc_repeat
|
||
|
|
|
||
|
|
after cancel $mc_repeat
|
||
|
|
set mc_repeat {}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc panel_drag {w cmd n} {
|
||
|
|
global mc_y
|
||
|
|
global mc_x
|
||
|
|
global mc_repeat
|
||
|
|
|
||
|
|
if {$mc_y >= [winfo height $w]} {
|
||
|
|
$w yview scroll 1 units
|
||
|
|
} elseif {$mc_y < 0} {
|
||
|
|
$w yview scroll -1 units
|
||
|
|
} else {
|
||
|
|
return
|
||
|
|
}
|
||
|
|
$cmd top [$w index @0,0]
|
||
|
|
$cmd motion $n [$w index @$mc_x,$mc_y]
|
||
|
|
set mc_repeat [after 50 panel_drag $w $cmd $n]
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# This routine passes the size of the text widget back to the C code
|
||
|
|
#
|
||
|
|
|
||
|
|
proc panel_size {cmd panel w h} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
set setup(real_height) $h
|
||
|
|
set setup(real_width) $w
|
||
|
|
|
||
|
|
if $setup(with_icons) {
|
||
|
|
set setup(height) [expr $h-setup(iconheight)]
|
||
|
|
set setup(width) [expr $w-$setup(iconwidth)]
|
||
|
|
set setup(lines) [expr $setup(height)/$setup(heightc)]
|
||
|
|
set setup(cols) [expr $setup(width)/$setup(widthc)]
|
||
|
|
} else {
|
||
|
|
set setup(height) $h
|
||
|
|
set setup(width) $w
|
||
|
|
set setup(lines) [expr $h/$setup(heightc)]
|
||
|
|
set setup(cols) [expr $w/$setup(widthc)]
|
||
|
|
}
|
||
|
|
$cmd resize $panel
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Called on the first idle loop to configure the sizes of the thing
|
||
|
|
#
|
||
|
|
proc panel_conf {panel cmd} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
set font [lindex [$panel configure -font] 4]
|
||
|
|
set fontinfo [$cmd fontdim $font $panel]
|
||
|
|
|
||
|
|
set setup(heightc) [lindex $fontinfo 0]
|
||
|
|
set setup(widthc) [lindex $fontinfo 1]
|
||
|
|
|
||
|
|
bind $panel <Configure> "panel_size $cmd $panel %w %h"
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Manage the bar that keeps the sort orders
|
||
|
|
#
|
||
|
|
proc panel_reset_sort_labels {win} {
|
||
|
|
# $win.m.p.types delete all
|
||
|
|
}
|
||
|
|
|
||
|
|
proc panel_sort_label_start {win} {
|
||
|
|
# $win.m.p.types delete all
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# This right now uses a canvas, creates labels and places them
|
||
|
|
# on the canvas. The button emulation is done with a manual
|
||
|
|
# bind.
|
||
|
|
#
|
||
|
|
|
||
|
|
proc panel_add_sort {win text_len text pos end_pos tag} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
if {$setup(with_sortbar) == 0} return
|
||
|
|
|
||
|
|
catch { destroy $win.m.p.types.$pos }
|
||
|
|
label $win.m.p.types.$pos -text $text -borderwidth 2 \
|
||
|
|
-font $setup(panelfont) -relief raised
|
||
|
|
|
||
|
|
$win.m.p.types create window $pos 0 -window $win.m.p.types.$pos -anchor nw
|
||
|
|
$win.m.p.types configure -height [expr $setup(heightc)+8]
|
||
|
|
$win.m.p.types create line $end_pos 1 $end_pos [expr $setup(heightc)-1] -fill gray
|
||
|
|
|
||
|
|
# Simulate the button.
|
||
|
|
bind $win.m.p.types.$pos <Button-1> "
|
||
|
|
$win.m.p.types.$pos configure -relief sunken
|
||
|
|
x$win sort $tag
|
||
|
|
after 100 { $win.m.p.types.$pos configure -relief raised }
|
||
|
|
"
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Called back from the action menu
|
||
|
|
#
|
||
|
|
proc popup_add_action {filename cmd idx} {
|
||
|
|
global setup
|
||
|
|
menu [set m .m.action] -tearoff 0
|
||
|
|
.m add cascade -foreground $setup(action_foreground) -label "$filename" -menu $m
|
||
|
|
$m add command -label "Info" -command "mc_file_info \"$filename\""
|
||
|
|
$m add command -label "Open with..." -command "mc_open_with \"$filename\""
|
||
|
|
$m add separator
|
||
|
|
$m add command -label "Copy..." -command "$cmd invoke %d Copy"
|
||
|
|
$m add command -label "Rename, move..." -command "$cmd invoke %d Move"
|
||
|
|
$m add command -label "Delete..." -command "$cmd invoke %d Delete"
|
||
|
|
$m add separator
|
||
|
|
$m add command -label "Open" -command "$cmd invoke %d Open"
|
||
|
|
$m add command -label "View" -command "$cmd invoke %d View"
|
||
|
|
}
|
||
|
|
|
||
|
|
proc start_drag {mode panel_cmd W x y X Y} {
|
||
|
|
global drag_mode
|
||
|
|
global drag_text
|
||
|
|
|
||
|
|
set drag_mode $mode
|
||
|
|
set drag_text [$panel_cmd dragtext [$W index @$x,$y]]
|
||
|
|
set drag_text "$mode $drag_text"
|
||
|
|
|
||
|
|
catch {destroy .drag}
|
||
|
|
toplevel .drag
|
||
|
|
wm overrideredirect .drag 1
|
||
|
|
wm withdraw .drag
|
||
|
|
label .drag.text -text "$drag_text"
|
||
|
|
pack .drag.text
|
||
|
|
wm deiconify .drag
|
||
|
|
wm geometry .drag +$X+$Y
|
||
|
|
}
|
||
|
|
|
||
|
|
proc drag_test {token} {
|
||
|
|
if {[winfo children $token] == ""} {
|
||
|
|
label $token.value -text "Zonzo"
|
||
|
|
pack $token.value
|
||
|
|
}
|
||
|
|
$token.value configure -text Hla
|
||
|
|
return "caca";
|
||
|
|
}
|
||
|
|
|
||
|
|
proc mc_drag_target {} {
|
||
|
|
global DragDrop
|
||
|
|
|
||
|
|
set data $DragDrop(text)
|
||
|
|
}
|
||
|
|
|
||
|
|
proc mc_drag_send {} {
|
||
|
|
# puts "drag send"
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Mouse bindings for the panels
|
||
|
|
#
|
||
|
|
proc panel_bind {the_panel panel_cmd} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
set pn "$the_panel.m.p.panel"
|
||
|
|
|
||
|
|
bind $pn <Button-1> "
|
||
|
|
$panel_cmd mdown 2 \[%W index @%x,%y]
|
||
|
|
"
|
||
|
|
|
||
|
|
bind $pn <ButtonRelease-1> "
|
||
|
|
panel_cancel_repeat
|
||
|
|
$panel_cmd mup 2 \[%W index @%x,%y]"
|
||
|
|
|
||
|
|
bind $pn <Double-1> "
|
||
|
|
panel_cancel_repeat
|
||
|
|
$panel_cmd double 2 \[%W index @%x,%y]"
|
||
|
|
|
||
|
|
bind $pn <B1-Motion> "
|
||
|
|
set mc_x %x
|
||
|
|
set mc_y %y
|
||
|
|
$panel_cmd motion 2 \[%W index @%x,%y]
|
||
|
|
"
|
||
|
|
|
||
|
|
bind $pn <B1-Leave> "
|
||
|
|
set mc_x %x
|
||
|
|
set mc_y %y
|
||
|
|
panel_drag %W $panel_cmd 2
|
||
|
|
"
|
||
|
|
|
||
|
|
bind $pn <B1-Enter> panel_cancel_repeat
|
||
|
|
|
||
|
|
if $setup(b2_marks) {
|
||
|
|
bind $pn <Button-2> "
|
||
|
|
$panel_cmd mdown 1 \[%W index @%x,%y]"
|
||
|
|
|
||
|
|
bind $pn <ButtonRelease-2> "
|
||
|
|
$panel_cmd mup 1 \[%W index @%x,%y]
|
||
|
|
panel_cancel_repeat
|
||
|
|
"
|
||
|
|
|
||
|
|
bind $pn <B2-Motion> "
|
||
|
|
set mc_x %x
|
||
|
|
set mc_y %y
|
||
|
|
$panel_cmd motion 1 \[%W index @%x,%y]
|
||
|
|
"
|
||
|
|
|
||
|
|
bind $pn <B2-Leave> "
|
||
|
|
set mc_x %x
|
||
|
|
set mc_y %y
|
||
|
|
panel_drag %W $panel_cmd 1
|
||
|
|
"
|
||
|
|
} else {
|
||
|
|
# We have blt
|
||
|
|
# blt_drag&drop source $pn config -button 2 -packagecmd drag_test \
|
||
|
|
# -selftarget 1
|
||
|
|
# blt_drag&drop source $pn handler text dd_send_file
|
||
|
|
}
|
||
|
|
|
||
|
|
# Menu popup.
|
||
|
|
bind $pn <Button-3> "
|
||
|
|
$panel_cmd mdown 2 \[%W index @%x,%y]
|
||
|
|
catch {destroy .m}
|
||
|
|
menu .m -tearoff 0
|
||
|
|
$panel_cmd load \[%W index @%x,%y] %X %Y
|
||
|
|
#Buggy Tk8.0
|
||
|
|
catch {tk_popup .m %X %Y}
|
||
|
|
"
|
||
|
|
|
||
|
|
bind $pn <B2-Enter> panel_cancel_repeat
|
||
|
|
|
||
|
|
$the_panel.m.scroll configure \
|
||
|
|
-command "panel_scroll $pn $panel_cmd"
|
||
|
|
$the_panel.m.p.scroll configure \
|
||
|
|
-command "$pn xview"
|
||
|
|
panel_conf $pn $panel_cmd
|
||
|
|
}
|
||
|
|
|
||
|
|
proc panel_info {item} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
return $setup($item)
|
||
|
|
}
|
||
|
|
|
||
|
|
proc panel_mark {tag panel n} {
|
||
|
|
config_colors $panel
|
||
|
|
$panel tag add $tag "${n}.0" "${n}.0 lineend"
|
||
|
|
}
|
||
|
|
|
||
|
|
# op is add or remove
|
||
|
|
proc panel_mark_entry {win op line} {
|
||
|
|
$win.m.p.panel tag $op marked $line.0 "$line.0 lineend"
|
||
|
|
}
|
||
|
|
|
||
|
|
proc panel_unmark_entry {win line} {
|
||
|
|
$win.m.p.panel tag remove selected $line.0 "$line.0 lineend"
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Misc routines
|
||
|
|
#
|
||
|
|
|
||
|
|
# Configure the panel tags
|
||
|
|
proc config_colors {which} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
# se -- selected file
|
||
|
|
$which tag configure selected -back $setup(panelcolor,selected_back)
|
||
|
|
|
||
|
|
foreach v {marked directory executable regular selected} {
|
||
|
|
$which tag configure $v -fore $setup(panelcolor,$v)
|
||
|
|
}
|
||
|
|
$which tag configure directory -font $setup(paneldir)
|
||
|
|
|
||
|
|
$which tag raise marked
|
||
|
|
}
|
||
|
|
|
||
|
|
proc tclerror {msg} {
|
||
|
|
puts stderr "TkError: [$msg]\n\r"
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# FIXME: This is not finished, have to deal with activefore, activeback
|
||
|
|
# highlight{fore,back}
|
||
|
|
#
|
||
|
|
proc error_colors {wins} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
foreach widget $wins {
|
||
|
|
catch "$widget configure -foreground $setup(errorfore)"
|
||
|
|
catch "$widget configure -background $setup(errorback)"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
#
|
||
|
|
# Layout routines
|
||
|
|
#
|
||
|
|
#
|
||
|
|
proc layout_midnight {} {
|
||
|
|
global one_window
|
||
|
|
global wlist
|
||
|
|
|
||
|
|
#puts $wlist
|
||
|
|
#
|
||
|
|
# we want to make the prompt and the input line sunken
|
||
|
|
# so we sunk the frame, and set a borderwidth for it
|
||
|
|
# while removing the sunken attribute set by the newinput
|
||
|
|
.p.i0 configure -relief flat
|
||
|
|
.p configure -relief sunken -borderwidth 2
|
||
|
|
pack .p.l5 -side left
|
||
|
|
pack .p.i0 -side left -expand 1 -fill x -anchor e
|
||
|
|
pack .n4 -side bottom -fill x
|
||
|
|
pack .p -side bottom -fill x
|
||
|
|
|
||
|
|
if $one_window {
|
||
|
|
pack .left -side top -side left -fill both -expand 1
|
||
|
|
pack .right -side top -side right -fill both -expand 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_query {} {
|
||
|
|
global wlist
|
||
|
|
|
||
|
|
# puts "$wlist"
|
||
|
|
set t [llength $wlist]
|
||
|
|
if {$t == 2} {
|
||
|
|
pack .query.l1 -side top -pady 2m -padx 2m
|
||
|
|
pack .query.b0 -side right -ipadx 2m -padx 4m -pady 2m -expand 1
|
||
|
|
} else {
|
||
|
|
pack .query.l1 -side top -pady 2m -padx 2m
|
||
|
|
|
||
|
|
for {set b 2} {$b != 1} {incr b} {
|
||
|
|
if {$b == $t} {
|
||
|
|
set b 0
|
||
|
|
}
|
||
|
|
pack .query.b$b -side right -ipadx 2m -padx 4m -pady 2m -expand 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_listbox {} {
|
||
|
|
scrollbar .listbox.s -width 3m -command {.listbox.x0 yview}
|
||
|
|
.listbox.x0 configure -yscroll {.listbox.s set}
|
||
|
|
pack .listbox.s -fill y -side right
|
||
|
|
pack .listbox.x0 -expand 1 -fill both -padx 4m -pady 4m -side left
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_quick_confirm {} {
|
||
|
|
pack .quick_confirm.c.c1 .quick_confirm.c.c2 .quick_confirm.c.c3 \
|
||
|
|
-side top -anchor w
|
||
|
|
pack .quick_confirm.b.b0 .quick_confirm.b.b4 -side left -padx 4m -expand 1
|
||
|
|
|
||
|
|
pack .quick_confirm.c -side top -pady 4m
|
||
|
|
pack .quick_confirm.b -side top -pady 2m
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_quick_file_mask {} {
|
||
|
|
global wlist
|
||
|
|
# puts stderr "$wlist"
|
||
|
|
|
||
|
|
# We add some space
|
||
|
|
.quick_file_mask configure -borderwidth 5m
|
||
|
|
|
||
|
|
pack .quick_file_mask.b.b1 .quick_file_mask.b.b2 \
|
||
|
|
-side left -expand 1 -padx 4m
|
||
|
|
|
||
|
|
pack .quick_file_mask.l3 -side top -anchor w -expand 1
|
||
|
|
pack .quick_file_mask.s.i5 -fill x -expand 1 -anchor w
|
||
|
|
pack .quick_file_mask.s.c6 -anchor e -padx 4m -pady 1m
|
||
|
|
pack .quick_file_mask.s -expand 1 -fill x -side top
|
||
|
|
|
||
|
|
pack .quick_file_mask.d.l7 -pady 4m
|
||
|
|
pack .quick_file_mask.d -side top -anchor w
|
||
|
|
pack .quick_file_mask.i4 -expand 1 -fill x -side top
|
||
|
|
|
||
|
|
pack .quick_file_mask.t.c8 .quick_file_mask.t.c0 -side top -anchor e
|
||
|
|
catch {pack .quick_file_mask.t.c9 -side top -anchor e}
|
||
|
|
|
||
|
|
pack .quick_file_mask.t -side top -anchor e
|
||
|
|
frame .quick_file_mask.space -height 4m
|
||
|
|
pack .quick_file_mask.space -side top
|
||
|
|
pack .quick_file_mask.b -fill x -expand 1 -side top
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_quick_vfs {} {
|
||
|
|
global wlist
|
||
|
|
# puts stderr "$wlist"
|
||
|
|
pack .quick_vfs.t.l1 -side left
|
||
|
|
pack .quick_vfs.t.i2 -side left -expand 1 -fill x -padx 2m
|
||
|
|
pack .quick_vfs.t.l3 -side left
|
||
|
|
|
||
|
|
pack .quick_vfs.l.l4 -side top -anchor w
|
||
|
|
pack .quick_vfs.l.r5 -side left -anchor w
|
||
|
|
pack .quick_vfs.l.i6 -side right -anchor se
|
||
|
|
pack .quick_vfs.b.b7 .quick_vfs.b.b0 -padx 4m -side left -expand 1
|
||
|
|
|
||
|
|
pack .quick_vfs.t -side top -expand 1 -fill x -pady 4m -padx 4m
|
||
|
|
pack .quick_vfs.l -side top -expand 1 -fill x -padx 4m
|
||
|
|
pack .quick_vfs.b -side top -expand 1 -fill x -padx 4m -pady 4m
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_dbits {} {
|
||
|
|
pack .dbits.r1 -anchor w -padx 4m -pady 4m -side top
|
||
|
|
pack .dbits.b0 -side top
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_chown {} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
pack .chown.b.b8 .chown.b.b0 -side left -padx 4m -expand 1
|
||
|
|
|
||
|
|
# May be invoked with different number of buttons
|
||
|
|
# There is already a problem: the cancel button is
|
||
|
|
# not close to the ok button, I will have to look into this.
|
||
|
|
catch {
|
||
|
|
pack .chown.b.b9 .chown.b.b10 .chown.b.b11 \
|
||
|
|
-side left -padx 4m -expand 1
|
||
|
|
}
|
||
|
|
label .chown.l.fname -text {File name}
|
||
|
|
label .chown.l.owner -text {Owner name}
|
||
|
|
label .chown.l.group -text {Group name}
|
||
|
|
label .chown.l.size -text {Size}
|
||
|
|
label .chown.l.perm -text {Permission}
|
||
|
|
|
||
|
|
pack \
|
||
|
|
.chown.l.fname .chown.l.l7 \
|
||
|
|
.chown.l.owner .chown.l.l6 \
|
||
|
|
.chown.l.group .chown.l.l5 \
|
||
|
|
.chown.l.size .chown.l.l4 \
|
||
|
|
.chown.l.perm .chown.l.l3 -side top -anchor w -padx 2m
|
||
|
|
|
||
|
|
foreach i {l3 l4 l5 l6 l7} {
|
||
|
|
.chown.l.$i configure -fore $setup(high)
|
||
|
|
}
|
||
|
|
pack .chown.l.l3 .chown.l.l4 .chown.l.l5 .chown.l.l6 .chown.l.l7 \
|
||
|
|
-side top -pady 1m -padx 4m -anchor w
|
||
|
|
|
||
|
|
# Configure the listboxes
|
||
|
|
scrollbar .chown.f.s -width 3m -command {.chown.f.x2 yview}
|
||
|
|
.chown.f.x2 configure -yscroll {.chown.f.s set}
|
||
|
|
label .chown.f.l -text {Group name}
|
||
|
|
pack .chown.f.l -side top -anchor w
|
||
|
|
pack .chown.f.x2 -side left -fill y -expand 1
|
||
|
|
pack .chown.f.s -side right -fill y -expand 1
|
||
|
|
|
||
|
|
scrollbar .chown.g.s -width 3m -command {.chown.g.x1 yview}
|
||
|
|
.chown.g.x1 configure -yscroll {.chown.g.s set}
|
||
|
|
label .chown.g.l -text {User name}
|
||
|
|
pack .chown.g.l -side top -anchor w
|
||
|
|
pack .chown.g.x1 -side left -fill y -expand 1
|
||
|
|
pack .chown.g.s -side right -fill y -expand 1
|
||
|
|
|
||
|
|
.chown.b configure -relief sunken
|
||
|
|
pack .chown.b -side bottom -pady 4m -fill x
|
||
|
|
pack .chown.g .chown.f -side left -padx 4m -pady 4m -expand 1 -fill y
|
||
|
|
pack .chown.l -side right -padx 4m
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_chmod {} {
|
||
|
|
global wlist
|
||
|
|
# puts stderr "$wlist \n\r"
|
||
|
|
pack .chmod.c.c5 .chmod.c.c6 .chmod.c.c7 .chmod.c.c8 .chmod.c.c9 \
|
||
|
|
.chmod.c.c10 \
|
||
|
|
.chmod.c.c11 .chmod.c.c12 .chmod.c.c13 .chmod.c.c14 .chmod.c.c15 \
|
||
|
|
.chmod.c.c16 -side top -anchor w
|
||
|
|
|
||
|
|
pack .chmod.b.b17 .chmod.b.b0 -side left -padx 4m -pady 4m -side left
|
||
|
|
catch {
|
||
|
|
pack .chmod.b.b18 .chmod.b.b19 .chmod.b.b19 .chmod.b.b20 \
|
||
|
|
.chmod.b.b21 -side left -padx 4m -pady 4m -side left
|
||
|
|
}
|
||
|
|
|
||
|
|
label .chmod.l.msg -text {Use "t" or Insert to\nmark attributes}
|
||
|
|
label .chmod.l.fname -text {Name}
|
||
|
|
label .chmod.l.perm -text {Permission (octal)}
|
||
|
|
label .chmod.l.owner -text {Owner name}
|
||
|
|
label .chmod.l.group -text {Group name}
|
||
|
|
|
||
|
|
pack \
|
||
|
|
.chmod.l.fname .chmod.l.l4 \
|
||
|
|
.chmod.l.perm .chmod.l.l1 \
|
||
|
|
.chmod.l.owner .chmod.l.l3 \
|
||
|
|
.chmod.l.group .chmod.l.l2 .chmod.l.msg -side top -anchor w -padx 2m
|
||
|
|
pack .chmod.b -side bottom
|
||
|
|
pack .chmod.l -side right -padx 4m -anchor n -pady 4m
|
||
|
|
pack .chmod.c -side left -padx 4m -pady 4m
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_view {} {
|
||
|
|
global wlist
|
||
|
|
|
||
|
|
pack [lindex $wlist 0] -side bottom -fill x
|
||
|
|
pack [lindex $wlist 1] -side top -expand 1 -fill both
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_replace {} {
|
||
|
|
global wlist
|
||
|
|
|
||
|
|
error_colors "$wlist .replace"
|
||
|
|
|
||
|
|
set alist {}
|
||
|
|
set plist {}
|
||
|
|
set ilist {}
|
||
|
|
|
||
|
|
foreach a $wlist {
|
||
|
|
if [regexp ^.replace.p.l $a] {
|
||
|
|
set plabel $a
|
||
|
|
} elseif [regexp ^.replace.p $a] {
|
||
|
|
set plist "$plist $a"
|
||
|
|
} elseif [regexp ^.replace.a.l $a] {
|
||
|
|
set alabel $a
|
||
|
|
} elseif [regexp ^.replace.a $a] {
|
||
|
|
set alist "$alist $a"
|
||
|
|
} elseif [regexp ^.replace.i $a] {
|
||
|
|
set ilist "$ilist $a"
|
||
|
|
} elseif [regexp ^.replace.b $a] {
|
||
|
|
set abortbutton $a
|
||
|
|
} else {
|
||
|
|
set fname $a
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# puts stderr "$wlist\n\r"
|
||
|
|
# puts stderr "alist: $alist\n\rplist: $plist\n\rilist: $ilist\n\r"
|
||
|
|
# puts stderr "plabel: $plabel\n\rfname: $fname"
|
||
|
|
|
||
|
|
pack $fname -side top -fill x -anchor w -pady 6m -padx 12m
|
||
|
|
pack $abortbutton -side bottom -anchor e -padx 8m -pady 4m
|
||
|
|
|
||
|
|
eval pack $ilist -side top -anchor w
|
||
|
|
pack .replace.i -padx 10m -pady 2m -anchor w
|
||
|
|
|
||
|
|
pack $plabel -side left -anchor w -padx 10m
|
||
|
|
eval pack $plist -side left -anchor e -fill x
|
||
|
|
pack .replace.p -side top -fill x -padx 10m
|
||
|
|
|
||
|
|
pack $alabel -side left -anchor w -padx 10m
|
||
|
|
eval pack $alist -side left -anchor e -fill x
|
||
|
|
pack .replace.a -side top -fill x -padx 10m
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_complete {} {
|
||
|
|
global wlist
|
||
|
|
|
||
|
|
eval pack $wlist -side top
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_opwin {} {
|
||
|
|
global wlist
|
||
|
|
global setup
|
||
|
|
|
||
|
|
pack .opwin.b.b0 .opwin.b.b14 -side left -expand 1
|
||
|
|
pack .opwin.f0.l1 .opwin.f0.l2 -side left -anchor w
|
||
|
|
pack .opwin.f1.l3 .opwin.f1.l4 -side left -anchor w
|
||
|
|
|
||
|
|
foreach a {.opwin.2.l11 .opwin.1.l8 .opwin.0.l5} {
|
||
|
|
$a configure -width 8
|
||
|
|
}
|
||
|
|
pack .opwin.2.l11 .opwin.2.g13 -side left -fill x
|
||
|
|
pack .opwin.1.l8 .opwin.1.g10 -side left -fill x
|
||
|
|
pack .opwin.0.l5 .opwin.0.l6 -side left -fill x
|
||
|
|
|
||
|
|
pack .opwin.b -side bottom -pady 4m -fill x
|
||
|
|
pack .opwin.f0 -side top -padx 10m -anchor w
|
||
|
|
pack .opwin.f1 -side top -padx 10m -pady 4m -anchor w
|
||
|
|
pack .opwin.0 .opwin.1 .opwin.2 -side top -padx 4m
|
||
|
|
}
|
||
|
|
|
||
|
|
proc dummy_layout {name} {
|
||
|
|
eval "proc layout_$name {} {
|
||
|
|
global wlist
|
||
|
|
# puts stderr \"\$wlist \\n\"
|
||
|
|
eval pack \$wlist -side top}"
|
||
|
|
}
|
||
|
|
#
|
||
|
|
# the achown commands will have to be rewriten
|
||
|
|
# to use only widgets and no writing callbacks.
|
||
|
|
#
|
||
|
|
|
||
|
|
foreach i {
|
||
|
|
achown tree
|
||
|
|
} {
|
||
|
|
dummy_layout $i
|
||
|
|
}
|
||
|
|
|
||
|
|
proc layout_quick_input {} {
|
||
|
|
global wlist
|
||
|
|
|
||
|
|
# puts stderr "$wlist \n\r"
|
||
|
|
.quick_input.i1 configure -width 60
|
||
|
|
label .quick_input.dummy
|
||
|
|
pack .quick_input.b.b2 .quick_input.b.b3 -side left -padx 4m -expand 1
|
||
|
|
pack .quick_input.b -side bottom -pady 4m
|
||
|
|
pack .quick_input.dummy -side top
|
||
|
|
pack .quick_input.l0 -side top -expand 1 -ipadx 2m -ipady 2m
|
||
|
|
pack .quick_input.i1 -side bottom -fill x -padx 4m
|
||
|
|
}
|
||
|
|
|
||
|
|
proc create_drop_target {name icon} {
|
||
|
|
toplevel .drop-$name
|
||
|
|
|
||
|
|
button .drop-$name.b -text "Drop target"
|
||
|
|
pack .drop-$name.b
|
||
|
|
wm group .drop-$name .
|
||
|
|
wm overrideredirect .drop-$name 1
|
||
|
|
wm withdraw .drop-$name
|
||
|
|
wm deiconify .drop-$name
|
||
|
|
wm geometry .drop-$name +0+0
|
||
|
|
# blt_drag&drop target .drop-$name.b handler file mc_drag_target
|
||
|
|
# blt_drag&drop target .drop-$name.b handler text mc_drag_target
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Creates the container
|
||
|
|
#
|
||
|
|
proc create_container {container} {
|
||
|
|
canvas $container
|
||
|
|
pack $container -fill both -expand 1
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Removes all of the widgets in a container (.left or .right)
|
||
|
|
#
|
||
|
|
proc container_clean {container} {
|
||
|
|
set widgets [winfo children $container]
|
||
|
|
|
||
|
|
foreach widget $widgets {
|
||
|
|
destroy $widget
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Setups the binding called after the layout procedure
|
||
|
|
#
|
||
|
|
proc bind_setup {win} {
|
||
|
|
flush stderr
|
||
|
|
bindtags $win {all $win}
|
||
|
|
wm protocol $win WM_DELETE_WINDOW "tkmc e scape"
|
||
|
|
bind $win <Leave>
|
||
|
|
}
|
||
|
|
|
||
|
|
proc keyboard_bindings {} {
|
||
|
|
# Remove the Tab binding.
|
||
|
|
bind all <Tab> {}
|
||
|
|
|
||
|
|
bind all <KeyPress> "tkmc r %A"
|
||
|
|
|
||
|
|
# Remove the Alt-key binding and put a sensible one instead
|
||
|
|
bind all <Alt-KeyPress> "tkmc a %A"
|
||
|
|
bind all <Control-KeyPress> "tkmc c %A"
|
||
|
|
bind all <Meta-KeyPress> "tkmc a %A"
|
||
|
|
|
||
|
|
foreach i {Left Right Up Down End R13 Home F27 F29 Prior \
|
||
|
|
Next F35 Return KP_Enter Delete Insert BackSpace \
|
||
|
|
F1 F2 F3 F4 F5 F6 F7 F8 F9 F10} {
|
||
|
|
bind all <Key-$i> "tkmc k %K"
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Centers a window based on .
|
||
|
|
proc center_win {win} {
|
||
|
|
global center_toplevels
|
||
|
|
|
||
|
|
wm transient $win [winfo toplevel [winfo parent $win]]
|
||
|
|
|
||
|
|
wm withdraw $win
|
||
|
|
update idletasks
|
||
|
|
|
||
|
|
if {$center_toplevels} {
|
||
|
|
set ch [winfo reqheight $win]
|
||
|
|
set cw [winfo reqwidth $win]
|
||
|
|
|
||
|
|
set geo [split [wm geometry .] +x]
|
||
|
|
set pw [lindex $geo 0]
|
||
|
|
set ph [lindex $geo 1]
|
||
|
|
set px [lindex $geo 2]
|
||
|
|
set py [lindex $geo 3]
|
||
|
|
|
||
|
|
set x [expr $px+(($pw-$cw)/2)]
|
||
|
|
set y [expr $py+(($ph-$ch)/2)]
|
||
|
|
|
||
|
|
wm geometry $win +$x+$y
|
||
|
|
}
|
||
|
|
wm deiconify $win
|
||
|
|
grab $win
|
||
|
|
tkwait visibility $win
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Busy window handling
|
||
|
|
#
|
||
|
|
proc win_busy {w} {
|
||
|
|
$w configure -cursor watch
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
#
|
||
|
|
# Color configurations
|
||
|
|
#
|
||
|
|
proc tk_colors {} {
|
||
|
|
}
|
||
|
|
|
||
|
|
proc color_model {} {
|
||
|
|
}
|
||
|
|
|
||
|
|
# gray85 is the background for the new tk4
|
||
|
|
proc gray_colors {base} {
|
||
|
|
global setup
|
||
|
|
global have_blt
|
||
|
|
|
||
|
|
#
|
||
|
|
# set setup(def_back) [tkDarken $base 90]
|
||
|
|
# set setup(def_fore) black
|
||
|
|
# set setup(selected) [tkDarken $base 110]
|
||
|
|
# set setup(marked) SlateBlue
|
||
|
|
# set setup(high) $setup(def_back)
|
||
|
|
|
||
|
|
if {0} {
|
||
|
|
set dark_color [tkDarken $base 90]
|
||
|
|
set setup(def_back) [tkDarken $base 110]
|
||
|
|
set setup(selected) NavyBlue
|
||
|
|
set setup(selected_fg) white
|
||
|
|
} else {
|
||
|
|
set dark_color $base
|
||
|
|
set setup(def_back) #d9d9d9
|
||
|
|
set setup(selected) white
|
||
|
|
set setup(selected_fg) black
|
||
|
|
}
|
||
|
|
set setup(def_fore) black
|
||
|
|
set setup(high) yellow
|
||
|
|
|
||
|
|
#
|
||
|
|
# Panel colors:
|
||
|
|
#
|
||
|
|
# Marked files
|
||
|
|
set setup(panelcolor,marked) yellow
|
||
|
|
set setup(panelcolor,directory) blue
|
||
|
|
set setup(panelcolor,executable) red
|
||
|
|
set setup(panelcolor,regular) black
|
||
|
|
set setup(panelcolor,selected_back) white
|
||
|
|
set setup(panelcolor,selected) black
|
||
|
|
|
||
|
|
# Viewer colors
|
||
|
|
|
||
|
|
set setup(view_bold) "-fore yellow -back $dark_color"
|
||
|
|
set setup(view_underline) "-fore red -back $dark_color"
|
||
|
|
set setup(view_mark) "-fore cyan -back $dark_color"
|
||
|
|
set setup(view_normal) "-fore black -back $dark_color"
|
||
|
|
|
||
|
|
# The percentage bars on info:
|
||
|
|
set setup(percolor) "blue"
|
||
|
|
|
||
|
|
# The sort bar colors
|
||
|
|
set setup(sort_fg) $setup(def_fore)
|
||
|
|
set setup(sort_bg) $setup(def_back)
|
||
|
|
set setup(with_sortbar) 1
|
||
|
|
|
||
|
|
# We use BLT only for drag and drop, if this is not available,
|
||
|
|
# then we use the 2nd button for regular file marking.
|
||
|
|
set have_blt 0
|
||
|
|
if $have_blt {
|
||
|
|
set setup(b2_marks) 0
|
||
|
|
} else {
|
||
|
|
set setup(b2_marks) 1
|
||
|
|
}
|
||
|
|
|
||
|
|
# The errors
|
||
|
|
set setup(errorfore) white
|
||
|
|
set setup(errorback) red
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
proc bisque_colors {} {
|
||
|
|
global setup
|
||
|
|
|
||
|
|
set setup(def_back) bisque3
|
||
|
|
set setup(def_fore) black
|
||
|
|
set setup(selected) bisque2
|
||
|
|
set setup(marked) SlateBlue
|
||
|
|
set setup(high) gray
|
||
|
|
}
|
||
|
|
|
||
|
|
proc sanity_check {} {
|
||
|
|
if [catch {bindtags .}] {
|
||
|
|
puts stderr "The Midnight Commander requires Tk 4.0 beta 3 or 4\n\r"
|
||
|
|
puts stderr "You can get it from: ftp://ftp.smli.com/pub/tcl"
|
||
|
|
exit 1
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#sanity_check
|
||
|
|
|
||
|
|
# Until I figure out how to remove specific bindings from a widget
|
||
|
|
# I remove all of the classes bindings.
|
||
|
|
|
||
|
|
#bind Text <Enter> {}
|
||
|
|
#bind Text <FocusIn> {}
|
||
|
|
|
||
|
|
# bind Entry <Enter> {}
|
||
|
|
# bind Entry <FocusIn> {}
|
||
|
|
|
||
|
|
keyboard_bindings
|
||
|
|
|
||
|
|
set setup(tearoff) 0
|
||
|
|
set setup(action_foreground) blue
|
||
|
|
set setup(lines) 24
|
||
|
|
set setup(cols) 40
|
||
|
|
set setup(with_icons) 0
|
||
|
|
set setup(widthc) 0
|
||
|
|
set setup(heightc) 0
|
||
|
|
set setup(real_width) 0
|
||
|
|
|
||
|
|
# Determine Tk version
|
||
|
|
set beta_4 ![catch tk_bisque]
|
||
|
|
if $beta_4 {
|
||
|
|
tk_setPalette gray85
|
||
|
|
gray_colors gray70
|
||
|
|
} else {
|
||
|
|
bisque_colors
|
||
|
|
}
|
||
|
|
|
||
|
|
## Some globals
|
||
|
|
set mc_repeat {}
|
||
|
|
set mc_x 0
|
||
|
|
set mc_y 0
|
||
|
|
set center_toplevels 1
|
||
|
|
#set center_toplevels 0
|
||
|
|
|
||
|
|
# button .testbutton [lindex [.testbutton configure -font] 3]
|
||
|
|
#set setup(panelfont) lucidasanstypewriter-bold-14
|
||
|
|
set setup(panelfont) lucidasanstypewriter-14
|
||
|
|
set setup(paneldir) lucidasanstypewriter-bold-14
|
||
|
|
set setup(font) "-*-helvetica-medium-r-normal-*-14-*-*-*-*-*-*-*"
|
||
|
|
|
||
|
|
#
|
||
|
|
#
|
||
|
|
# This variable if set, will make the program load gui.*.tcl files
|
||
|
|
# instead of the gui.tcl file created during instalaltion.
|
||
|
|
set use_separate_gui_files 0
|
||
|
|
|
||
|
|
if [file exist ~/.mc/tkmc] {source ~/.mc/tkmc}
|
||
|
|
|
||
|
|
catch {
|
||
|
|
# option add *font $setup(font) userDefault
|
||
|
|
# option add *Menu*activeBackground NavyBlue
|
||
|
|
# option add *Menu*activeForeground white
|
||
|
|
# option add *Menubutton*activeBackground NavyBlue
|
||
|
|
# option add *Menubutton*activeForeground white
|
||
|
|
# option add *Button*activeBackground NavyBlue
|
||
|
|
# option add *Button*activeForeground white
|
||
|
|
## set setup(panelfont) $setup(font)
|
||
|
|
}
|
||
|
|
|
||
|
|
proc run_gui_design {root} {
|
||
|
|
global components
|
||
|
|
|
||
|
|
create_workspace $root
|
||
|
|
gui_design $root $components
|
||
|
|
}
|
||
|
|
|
||
|
|
source $LIBDIR/gd.tcl
|
||
|
|
|
||
|
|
set tk_strictMotif 1
|
||
|
|
create_top_menu
|
||
|
|
|
||
|
|
create_drop_target Hola Zonzo
|