1#! /usr/local/bin/wish8.6 2# -*- tcl -*- 3# <20190703.1805.26> 4 5lappend startTimes [list [clock milliseconds] "First light"] 6 7# Copyright � 2010-20** Tom Turkey (see var Copyright or About for latest year) 8# Copyright � 1996-1999 Henrik Harmsen 9# So we don't have to tell about the GPL again... 10 11proc About {} { 12 global glob 13 smart_dialog .apop[incr ::uni] .\ 14 [_ "About FileRunner"] \ 15 [list [_ "FileRunner version %s 16 17 %s 18 19FileRunner is Free Software distributed under the 20GNU General Public License. FileRunner comes with 21ABSOLUTELY NO WARRANTY. 22See menu Help/Copying for further details. 23" $glob(displayVersion) $::Copyright]] 0 1 [_ "OK"] \ 24 [list -font -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-* \ 25 tag {config tag -justify center} \ 26 -borderwidth 10\ 27 -flashon 0] 28} 29 30 31proc indexFor {what} { 32 return [lsearch -exact $::glob(fListEl) $what] 33} 34 35 36proc _ {s {p1 ""} {p2 ""} {p3 ""} {p4 ""} } { 37 return [::msgcat::mc $s $p1 $p2 $p3 $p4]}; 38proc _b {s {p1 ""} {p2 ""} {p3 ""} } {return [::msgcat::mc $s $p1 $p2 $p3]}; 39 40proc bgerror {err} { 41 global errorInfo env glob tcl_patchLevel tk_patchLevel ignor_error_flag 42 43 # IsKnownError returns for us on known errors 44 while {$::DoProtLevel > 0} {UnDoProtCmd} 45 IsKnownError $err 46 47 if {$glob(abortcmd) > 0} { 48 # note it and ignor it... 49 frputs "Ignoring error during abort: $errorInfo" 50 LogSilent "Error: during abort, ignoring: $errorInfo" 51 return 52 } 53 if {[info exists ignor_error_flag] } { 54 smart_dialog .bgerrorDialog[incr ::uni] .\ 55 [_ "no-no"]\ 56 [list $ignor_error_flag] \ 57 0 1 [_ "OK"] 58 return 59 } 60 set info "${errorInfo}" 61 set button [smart_dialog .bgerrorDialog[incr ::uni] .\ 62 [_ "Fatal error in Tcl Script"] \ 63 [list [_ "You have found a bug. It might be in FileRunner.\n\ 64 \n"] \ 65 "$err" \ 66 [_ "\n\nPlease send a bugreport to the author."]] \ 67 0 4 [list [_ "Exit"] [_ "See Stack Trace"] \ 68 [_ "Prepare bugreport"] [_ "Ignor" ]]] 69# puts "$button" 70 switch $button { 71 3 {return} 72 0 {exit 1} 73 2 { buildBugReport $err $info} 74 1 { 75 set ans [smart_dialog .bgerrorTrace[incr ::uni] . [_ "Stack Trace for Error"]\ 76 [list $info ]\ 77 -1 3 [list [_ "Exit"] [_ "Prepare bugreport"] [_ "Continue"]]] 78 switch $ans { 79 0 {exit 1} 80 1 { 81 buildBugReport $err $info 82 } 83 } 84 } 85 } 86 return 87} 88 89 90# The buildStop routine builds a small window with a Stop button and a 91# one line static message. It is assumed that the message ids the button so 92# several may be on the display at one time. 'w' is name used as the 93# parent of the stop window which will be inserted as the first entry in 'w 94# A dynamic line is also provided to display status. This line is written 95# (and over written) by calling "StopProgress w mess" 96 97# The name of the frame of the stop window is returned, 98# 99# The stop command/button has 3 states 0, 1 and 2. It has a color to match 100# its state: 0 normal button color, 1 flash color, 2 select fg color 101# 102# Stop will normally be in state 0 when the window is created (see over ride) 103# When pushed, call back to call back function with parm = 0 move to state 1 104# 105# When pushed, call back to call back function with parm = 1 moves to state 2 106# 107# when pushed, call back to call back function with parm = 2 stays in state 2 108# 109# We keep the call back script and state in the button command script 110# 111# When called, this routine measures the window "w" and returns this measure 112# As part of popping the stop button into the window, the rest of the window 113# is hidden by sizeing it. 114# When the caller wishs to remove the stop button s/he should do: 115# StopButRemov w where 'w' is the window passed in 116# This will resize the window and remove the 117# stop button pane. 118# 119proc buildStop {w mess callback {stopState 0}} { 120 global config glob 121 set wf [frame $w.f -bg $glob(gui,color_bg)] 122 if {$mess != {}} { 123 set mb [label $wf.l -text $mess -bg $glob(gui,color_bg) -justify left] 124 grid $mb -in $wf -row 1 -column 2 -sticky w 125 } 126 set sb [button $wf.b -text [_ "Stop"]] 127 grid $sb -in $wf -row 1 -column 1 -sticky ew 128 grid columnconfigure $wf 1 -weight 0 129 grid columnconfigure $wf 2 -weight 1 130 $sb config -activebackground $glob(gui,color_select_fg) 131 switch $stopState { 132 1 {$sb config -bg $glob(gui,color_flash)} 133 2 {$sb config -bg $glob(gui,color_select_fg)} 134 } 135 while {[lassign [split [winfo geo $w] x+] p q f] == 0} { 136 update 137 if {! [winfo exists $w]} {return {}} 138 if {[incr loop] > 100} {break} 139 } 140 frputs loop 141 #after idle "frputs \"[wm geo $w] \"" 142 lassign [split [wm geo $w] x+] wd h 143 lassign [split [winfo geo $w] x+] d d px py 144 145 wm geo $w ${wd}x2+$px+$py 146 # It is possible that this window is already gone... so... 147 if {[catch "grid $wf -in $w -row 0 -column 0 -columnspan 2 -sticky ew"] == 0} { 148 bind $w.f.b <Destroy> "stopDestroy $w $callback" 149 $sb config -command "StopBut $sb ${wd}x$h $callback $stopState" 150 } 151 return ${wd}x$h+$px+$py 152} 153 154# the following routine is provided for those cases where we don't 155# know the callback function until after the 'buildStop' call 156# Because 'buildStop' calls update, for example, it needs to be 157# called prior to 'pipeoExec' which returns a fid that one 158# might want to put in the callback. 159 160proc stopReSetCallBack {w callback {stopState 0}} { 161 if {![winfo exists $w.f.b]} {return} 162 set old [bind $w.f.b <Destroy>] 163 bind $w.f.b <Destroy> [lreplace $old end end {*}$callback] 164 set old [$w.f.b cget -command] 165 $w.f.b config -command [lreplace $old end-1 end {*}$callback $stopState] 166} 167 168proc stopDestroy {w args} { 169 # if the stop button is already gone, just return 170 frputs "stopDestroy [winfo exists $w.f.b] " w args 171 if {![winfo exists $w.f.b]} {return} 172 # prevent a second entry 173 # destroy $w.f 174 # do the stop call back with a "2", should stop the process 175 eval "$args 2" 176} 177 178proc StopBut {sb geo args} { 179 global config glob 180 set stopState [lindex $args end] 181 switch [incr stopState] { 182 1 {$sb config -bg $glob(gui,color_flash)} 183 2 {$sb config -bg $glob(gui,color_select_fg)} 184 default {set stopState 2} 185 } 186 $sb config -command "StopBut $sb $geo [lreplace $args end end $stopState]" 187 # must do this last as the window may not exist after 188 frputs "StopBut " stopState args 189 eval $args 190} 191 192# this code resizes the window and removes the stop button frame 193# given the toplevel window name 194# 195proc StopButRemove {w} { 196 set r [catch {$w.f.b config -command} cmd] 197 if {$r != 0} {frputs "StopButRemove " cmd ;return} 198 bind $w.f.b <Destroy> {} 199 lassign [split [wm geo $w] x+] d h 200 # only mess with the size if it is still just the stop button 201 if {$h == 0} { 202 wm geo $w [lindex $cmd 4 2] 203 } 204 destroy $w.f 205} 206 207# this function writes progress messages to the stop subwindow 208proc StopProgress {w mess} { 209 global glob 210 if {![winfo exist $w.f.p]} { 211 set pb [label $w.f.p -bg $glob(gui,color_bg) -justify left] 212 grid $pb -in $w.f -row 2 -column 1 -columnspan 2 -sticky w 213 } 214 $w.f.p config -text $mess 215} 216 217# a debug function to print lists one entry per line 218proc pls {s} { 219 foreach l $s { 220 puts "$l" 221 } 222} 223 224 225proc buildBugReport {err info} { 226 global glob env 227 set count {} 228 while {[file exists $env(HOME)/filerunner_bugreport$count.txt]} { 229 if {$count == {}} { 230 set count 0 231 } 232 incr count 233 } 234 235 set r [catch {open $env(HOME)/filerunner_bugreport$count.txt w} fid] 236 if {$r} { 237 smart_dialog .bugrepinfo[incr ::uni] .\ 238 [_ "Error"] \ 239 [list [_ "Can't create file:\n"]\ 240 "$env(HOME)/filerunner_bugreport$count.txt" \ 241 [_ "\nto dump bugreport. Error:\n"] \ 242 " $fid" ] \ 243 0 1 [_ "Exit"] 244 exit 1 245 } 246 puts $fid [_ "\nBugreport for FileRunner version %s\ 247 created %s.\n" $glob(displayVersion) [clock format [clock seconds]]] 248 puts $fid [_ "Please fill in/correct the rest of this and send\ 249 it to %s.\n\n" tom@wildturkeyranch.net] 250 set r [catch { exec uname -a } output] 251 if {$r} { set output "" } 252 puts $fid [_ "Operating System : %s" $output] 253 puts $fid [_ "Tcl/Tk version : %s / %s" $::tcl_patchLevel $::tk_patchLevel] 254 puts $fid [_ "Comments : "] 255 puts $fid [_ "\nError string : %s" $err] 256 puts $fid [_ "\nStack trace follows:\n--------------------\n%s" $info] 257 catch {close $fid} 258 if {[smart_dialog .bugrepinfo[incr ::ini] .\ 259 [_ "Error"] \ 260 [list [_ "Bug report file saved to:\n"] \ 261 $env(HOME)/filerunner_bugreport \ 262 [_ ".\nPlease fill in the rest of it\ 263 and send it to the author."]] \ 264 0 2 [list [_ "Exit"] [_ "Continue"]]] == 0 } { 265 exit 1 266 } 267} 268 269# here is a routine to generate a large button window with a small bitmap 270# The issue is that 'openbox' does not properly render such windows 271# We avoid this by creating 3 button windows two of which are blank 272# and can be expanded to fill the space. All do the same thing... 273# 274# First a helper routine to change color of the fill 275# 276proc buttonWbitmapColor {path ent} { 277 set whichColor [expr {$ent ? "-activebackground" : "-bg"}] 278 set newColor [$path.mid cget $whichColor] 279 $path.pre config -bg $newColor 280 $path.post config -bg $newColor 281 $path.mid config -state [expr {$ent ? "active" : "normal"}] 282} 283 284# version 1: 285proc buttonWbitmap {path args} { 286 # If there is a command, remove it from the list. We will use bind.. 287 set ops {} 288 set border {} 289 foreach {op val} $args { 290 switch -glob $op { 291 "-com*" {set command $val} 292 "-bd" - 293 "-rel*" - 294 "-bord*" {lappend border $op $val} 295 default { lappend ops $op $val} 296 } 297 } 298 frame $path {*}$border 299 #puts "$path $border" 300 button $path.mid {*}$ops -borderwidth 0 -default disabled 301 canvas $path.pre -borderwidth 0 -height 0 -width 0 302 canvas $path.post -borderwidth 0 -height 0 -width 0 303 grid $path.pre $path.mid $path.post -row 1 -sticky nsew 304 grid columnconfigure $path [list $path.pre $path.post] -weight 1 -minsize 1 305 grid columnconfigure $path $path.mid -weight 0 306 307 bind $path.pre <ButtonRelease-1> $command 308 bind $path.mid <ButtonRelease-1> $command 309 bind $path.post <ButtonRelease-1> $command 310 311 bind $path.pre <Enter> "buttonWbitmapColor $path 1" 312 bind $path.mid <Enter> "buttonWbitmapColor $path 1" 313 bind $path.post <Enter> "buttonWbitmapColor $path 1" 314 315 bind $path.pre <Leave> "buttonWbitmapColor $path 0" 316 bind $path.mid <Leave> "buttonWbitmapColor $path 0" 317 bind $path.post <Leave> "buttonWbitmapColor $path 0" 318 return $path 319} 320#################################### Map of our windows ##################### 321# A map of the filerunner windows, well, most of them: 322 323# .fupper 324# .ftop aka glob(win,top) 325# .menu_frame (short term aka wf ) 326# .file_but 327# .m (a menu) 328# .configuration_but 329# .m (a menu) 330# .utils_but 331# .m (a menu) 332# .help_but 333# .m (a menu) 334# .fasync_cmds (short term aka w) 335# .1 --- one for each fast checkbox 336# .abort 337# .clone (moved to utils menu) 338# .clock 339# .user 340# .selectTex aka glob(selectWindow) this window is never displayed 341# .can aka glob(win,can) (a canvas) (short term aka wc) 342# .fmiddle aka glob(win,middle) (short term aka wm) 343# .1 --- one of these for each middle button 344# .scroll Top 7 buttons in middle col (short term aka wscr) 345# .up 346# .down 347# .left 348# .right 349# .fs 350# .1 351# .2 352# .3 353# .fleft aka glob(win,left) (to the left of the buttons) 354# .frame_listb (passed to multilist) 355# .top 356# .c 357# .file, .mode, .mtime, .owner, .size, .slink (and scrolls) 358# .ca 359# .sb 360# .v 361# .but 362# .vs 363# .top (short term aka wft) 364# .button_back 365# .button_update 366# .stat (label shows disk size, etc.) 367# .button_frterm (opens bottom window) 368# .button_xterm 369# .dirmenu_frame (short term aks wf) 370# .dir_but (tree button not in MSW version) 371# .m (this is the tree.bit button) 372# .hotlist_but 373# .m 374# .history_but 375# .m 376# .etc_but 377# .m 378# .button_parentdir 379# .entry_dir 380# .c (returned from multilist) 381# 382# .fright aka glob(win,right) (to the right of the buttons) (same as .fleft) 383# 384 385# .flower aka glob(win,bottom) 386# .fcmdwinleft (also .fcmdwinright) 387# .text 388# .scroll 389# .bot 390# .label (contains pwd) 391# .entry 392# .max 393# .smaller 394# .larger 395# .running 396 397 #xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 398proc setBalloon {} { 399 global glob 400 set wf $glob(win,top).menu_frame 401 balloonhelp_for $wf.file_but {[_b "Push it to see..." ]} 402 balloonhelp_for $wf.configuration_but {[_b "Push it to see..." ]} 403 balloonhelp_for $wf.utils_but {[_b "Push it to see..." ]} 404 balloonhelp_for $wf.help_but {[_b "Push it to see..." ]} 405 balloonhelp_for $wf.abort \ 406 {[_b "Attempts to abort a running async command" ]} 407 # balloonhelp_for $wf.clone \ 408 # {[_b "Creats a clone of filerunner in the same dirs as this one." ]} 409 balloonhelp_for $wf.clock \ 410 {[_b "Current date & time of day." ]} 411 balloonhelp_for $glob(win,top).status \ 412 {[_b "Status message line.\ 413 \nFull info on selected file appears here.\ 414 \nAlso other progress messages show up here." ]} 415 balloonhelp_for $wf.user \ 416 {[_b "Current user & machine names." ]} 417 set wscr .fupper.scroll 418 foreach ud {up down} { 419 balloonhelp_for $wscr.$ud \ 420 {[_b "Scroll the center buttons\ 421 \n(mouse wheel anywhere on buttons does this too)." ]} 422 # balloonhelp_for $wscr.up \ 423 # {[_b "Scroll the center buttons\ 424 # \n(mouse wheel anywhere on buttons does this too)." ]} 425 } 426 balloonhelp_for $wscr.fs.mid {[_b "Lock/unlock left/right column order & \ 427 sizes\nIf locked, changing one changes both.\n"]} 428 foreach {inst ninst} {left right right left} { 429 set wft $glob(win,$inst).top 430 set f {} 431 balloonhelp_for $wscr.$inst "\[_b \"Dup $ninst dir list in $inst.\"]" 432 balloonhelp_for $wscr.fs.$inst\ 433 "\[_b \"Dup $ninst column order and size on $inst.\"]" 434 } 435 balloonhelp_for $wft.button_back \ 436 {[_b "Go back thru the push down stack of dir visits." ]} 437 balloonhelp_for $wft.button_xterm \ 438 {[_b "Launch the user specified\n terminal\ 439 program in a new window." ]} 440 balloonhelp_for $wft.button_frterm \ 441 {[_b "Open/Close a command sub\n window\ 442 at the bottom of this one." ]} 443 balloonhelp_for $wft.button_update \ 444 {[_b "Update the dir list." ]} 445 balloonhelp_for $glob(win,$inst).entry_dir \ 446 {[_b "Dir line.\nFollows dir changes.\nEnter\ 447 a new dir here if desired.\nAlso\ 448 used as input by MkDir and Select\n buttons.\ 449 Button 2 (paste) of a file name here\nwill\ 450 open the referenced dir and select\nthe\ 451 file after traceing links." ]} 452} 453 454 455proc buildConfigMenu {configmenu} { 456 global glob config 457 # Create CONFIGURATION menu 458 if {[$configmenu index end] != "none"} {return} 459 $configmenu add command \ 460 -label {Save Configuration} -command SaveConfig 461 $configmenu add command \ 462 -label {Edit Configuration...} -command ConfigBrowser 463 $configmenu add command \ 464 -label {Reread Configuration} -command { 465 ReadConfig;ForceUpdate;Log [_ "Configuration re-read"] 466 } 467 $configmenu add separator 468 469 $configmenu add check \ 470 -label [_ "Expanded Error Messages"] -variable glob(debug) \ 471 -command "setupDebug \$glob(debug)" 472 $configmenu add check \ 473 -label [_ "Balloon Help"] -variable config(balloonhelp) \ 474 -command {set ::balloon_help::enable $config(balloonhelp)} 475 set ::balloon_help::enable $config(balloonhelp) 476 $configmenu add check \ 477 -label [_ "Position to directories"] -variable config(positiondirs) 478 $configmenu add check \ 479 -label [_ "Show All Files"] -variable config(fileshow,all) \ 480 -command ForceUpdate 481 #bind $configmenu <ButtonRelease> "$configmenu invoke active; break" 482 if { !$::MSW } { 483 $configmenu add check \ 484 -label [_ "Create Relative Links"] \ 485 -variable config(create_relative_links) 486 } 487 $configmenu add check \ 488 -label [_ "Run Pwd After Cd"] -variable config(cd_pwd) 489 $configmenu add check \ 490 -label [_ "Run Pwd After Cd (VFS)"] -variable config(ftp,cd_pwd) 491 492 # Contrary to the documentation the variable seems to get updated 493 # after the command. The 1ms wait fixes things... 494 $configmenu add check \ 495 -onvalue 1 -offvalue 0 \ 496 -label [_ "Focus Follows Mouse"] -variable config(focusFollowsMouse) \ 497 -command {after 1 "if {$config(focusFollowsMouse)== 1} \ 498 {tk_focusFollowsMouse} "} 499 $configmenu add check \ 500 -label [_ "Use FTP Proxy"] -variable config(ftp,useproxy) 501 $configmenu add separator 502 $configmenu add cascade -menu $configmenu.sortOps -label "Sort Options" 503 menu $configmenu.sortOps -tearoff true -tearoffcommand FixTearoff\ 504 -title "Sort OptionsMenu" -font $glob(gui,GuiFont) 505 $configmenu.sortOps add radio \ 506 -label [_ "ASCII sort"] -variable config(sortoption) \ 507 -value "-ascii" -command ForceUpdate 508 $configmenu.sortOps add radio \ 509 -label [_ "Ignore case on sort"] -variable config(sortoption) \ 510 -value "-nocase" -command ForceUpdate 511 $configmenu.sortOps add radio \ 512 -label [_ "Dictionary sort"] -variable config(sortoption) \ 513 -value "-dictionary" -command ForceUpdate 514 515 $configmenu.sortOps add separator 516 $configmenu.sortOps add radio \ 517 -label [_ "Sort Dirs First"] -variable config(fileshow,dirs) \ 518 -value dirsfirst -command ForceUpdate 519 $configmenu.sortOps add radio \ 520 -label [_ "Sort Dirs Last"] -variable config(fileshow,dirs) \ 521 -value dirslast -command ForceUpdate 522 $configmenu.sortOps add radio \ 523 -label [_ "Dirs Mixed"] -variable config(fileshow,dirs) \ 524 -value mixed -command ForceUpdate 525 $configmenu.sortOps add separator 526 $configmenu.sortOps add radio \ 527 -label [_ "Sort On Name"] -variable config(fileshow,sort) \ 528 -value nameonly -command ForceUpdate 529 $configmenu.sortOps add radio \ 530 -label [_ "Sort On Modify Time"] -variable config(fileshow,sort) \ 531 -value mtime -command ForceUpdate 532 $configmenu.sortOps add radio \ 533 -label [_ "Sort On Access Time"] -variable config(fileshow,sort) \ 534 -value atime -command ForceUpdate 535 $configmenu.sortOps add radio \ 536 -label [_ "Sort On Create Time"] -variable config(fileshow,sort) \ 537 -value ctime -command ForceUpdate 538 $configmenu.sortOps add radio \ 539 -label [_ "Sort On Reverse Modify Time"] -variable config(fileshow,sort) \ 540 -value rmtime -command ForceUpdate 541 $configmenu.sortOps add radio \ 542 -label [_ "Sort On Reverse Access Time"] -variable config(fileshow,sort) \ 543 -value ratime -command ForceUpdate 544 $configmenu.sortOps add radio \ 545 -label [_ "Sort On Reverse Access Time"] -variable config(fileshow,sort) \ 546 -value rctime -command ForceUpdate 547 $configmenu.sortOps add radio \ 548 -label [_ "Sort On Size"] -variable config(fileshow,sort) \ 549 -value size -command ForceUpdate 550 $configmenu.sortOps add radio \ 551 -label [_ "Sort On Extension"] -variable config(fileshow,sort)\ 552 -value extension -command ForceUpdate 553 $configmenu add separator 554 $configmenu add cascade -menu $configmenu.color -label "Color Edit Menu" 555 menu $configmenu.color -tearoff true -tearoffcommand FixTearoff \ 556 -title "Color Edit Menu" -font $glob(gui,GuiFont) 557 $configmenu add separator 558 $configmenu.color add command \ 559 -label {Edit Entry BG Color...} -command "EditColor color_bg" 560 $configmenu.color add command \ 561 -label {Edit Entry FG Color...} -command "EditColor color_fg" 562 $configmenu.color add command \ 563 -label {Edit Selection BG Color...} -command "EditColor color_select_bg" 564 $configmenu.color add command \ 565 -label {Edit Selection FG Color...} -command "EditColor color_select_fg" 566 $configmenu.color add command \ 567 -label {Edit Highlight BG Color...} -command "EditColor color_highlight_bg" 568 $configmenu.color add command \ 569 -label {Edit Highlight FG Color...} -command "EditColor color_highlight_fg" 570 $configmenu.color add command \ 571 -label {Edit Lisbox handle Color...} -command "EditColor color_handle" 572 $configmenu.color add command \ 573 -label {Edit Shell Cmd Color...} -command "EditColor color_cmd" 574 $configmenu.color add command \ 575 -label {Edit Color Scheme...} -command "EditColor color_scheme" 576 $configmenu.color add command \ 577 -label {Edit Cursor Color...} -command "EditColor color_cursor" 578 $configmenu.color add command \ 579 -label {Edit Flash Color...} -command "EditColor color_flash" 580 $configmenu.color add command \ 581 -label {Edit Balloon Help FG Color...} \ 582 -command "EditColor color_balloonHelp_fg" 583 $configmenu.color add command \ 584 -label {Edit Balloon Help BG Color...} \ 585 -command "EditColor color_balloonHelp_bg" 586 $configmenu add command \ 587 -label {Edit Fonts} -command "DoEditFont" 588 $configmenu add separator 589 $configmenu add command \ 590 -label {Set Start Dir Left} -command "DoProtCmd \"SetStartDir left\"" 591 $configmenu add command \ 592 -label {Set Start Dir Right} -command "DoProtCmd \"SetStartDir right\"" 593 $configmenu add radio \ 594 -label [_ "Set Column Scroll Bar Off"] -variable config(columnScroll) \ 595 -value 0 -command "BuildListBoxes" 596 $configmenu add radio \ 597 -label [_ "Set Column Scroll Bar Top"] -variable config(columnScroll) \ 598 -value 1 -command "BuildListBoxes" 599 $configmenu add radio \ 600 -label [_ "Set Column Scroll Bar Bottom"] -variable config(columnScroll) \ 601 -value 3 -command "BuildListBoxes" 602 $configmenu add command \ 603 -label {Set Window Pos/Size} -command "SetWinPos" 604} 605proc buildFileMenu {wf} { 606 # Create FILE menu 607 $wf.file_but.m delete 0 end 608 $wf.file_but.m add command \ 609 -label About... \ 610 -command About 611 $wf.file_but.m add command \ 612 -label [_ "View Log..."] \ 613 -command { ViewLog } 614 $wf.file_but.m add command\ 615 -label [_ "View Error Window"]\ 616 -command {PopError {}} 617 618 $wf.file_but.m add command \ 619 -label Quit -command { CleanUp 0 } 620} 621proc buildUtilsMenu {wf} { 622 # Create Utilities menu 623 # A "+" in the following list means that the command and its label will be 624 # added to the list of command available to user configured menues. 625 # We want the first item in the utilites menu on MSW to be the start menu 626 # and, at the same time, the 3ed item to be the elevate/root command. So... 627 set opClean {} 628 $wf.utils_but.m delete 0 end 629 set startMenuHook [list {-label {Clean (destroy View windows)} -command {Clean}}\ 630 {-label {Prob monitor(s) workspace}\ 631 -command {Try {::displays::init} -a}}] 632 if {$::MSW} { 633 # set this when we have the code... 634 set startMenuHook {} 635 # set startMenuHook [list {-label {Start Menu} -command {winStartMenu}}] 636 set opClean [list {-label {Clean (destroy View windows)} -command {Clean}}] 637 } 638 ButtonAdd $wf.utils_but.m {} \ 639 [concat \ 640 [list {*}$startMenuHook\ 641 {+-label {Swap Windows} -command {P CmdSwapWindows}}\ 642 {+-label {[lindex $::config(cmd,ucmd) 0]}\ 643 -command {eval [lindex $::config(cmd,ucmd) 1]}}\ 644 {*}$opClean\ 645 {+-label {What Is?...} -command {P CmdWhatIs}}\ 646 {+-label {Select On Contents...} -command {P CmdCSelect}}\ 647 {+-label {Run Command} -command {P CmdRunCmd}}\ 648 {+-label {Check Size Of Selected...} -command {P CmdCheckSize}}\ 649 {-label {Clone} -command {Clone}}\ 650 {-label {Show Console} -command\ 651 {catch { 652 if {![winfo exists .tkcon]} { 653 Log "loading tkconrc" 654 set tkconrcVer [package require tkconrc] 655 Log "tkconrc $tkconrcVer loaded" 656 after 20 657 } 658 tkcon show 659 realWaitForIdle 660 # here is a little jig we dance to get the 661 # window on top but not fixed there 662 wm withdraw .tkcon 663 wm attribute .tkcon -topmost 1 664 wm deiconify .tkcon 665 wm attribute .tkcon -topmost 0 666 } duh; frputs duh 667 }}] \ 668 $::UtilsMenu::ents] 669 670} 671 #bind $wf.configuration_but <1> "::tk_popup $wf.configuration_but.m %X %Y;break" 672proc ShowWindow {} { 673 global glob tk_version argv argv0 config env win fast_checkboxes tcl_platform 674 lappend ::startTimes [list [clock milliseconds] "Start Main Window build"] 675 wm positionfrom . user 676 wm sizefrom . "" 677 wm title . "FileRunner v$glob(displayVersion)" 678 wm geometry . [getGeo $config(geometry,main) .] 679 wm protocol . WM_DELETE_WINDOW { CleanUp 0 } 680 wm iconname . "FileRunner v$glob(displayVersion)" 681 wm command . [concat $argv0 $argv] 682 wm group . . 683 684 frame .fupper -bd 0 685 frame .flower -bd 0 686 .flower config -background blue 687 # puts "$glob(win,top)" 688 frame $glob(win,top) -borderwidth 2 -relief raised 689 # TOP LEVEL MENU BUTTONS 690 # Just for those who want to know (mainly me) we don't use a menubar because: 691 # a) we want some simple buttons here, e.g. "stop" 692 # b) we want checkboxes here (fast check boxes) 693 # c) we are also putting various bits of info here (name@machine, current time) 694 # 695 # To get the cascade to work in menus we want it, we change the <Motion> binding 696 # to use to conditionally alter (actually define) an ::tk:: internal. 697 698 # In an attempt to speed up the start up code (or what is so perceived) we defer 699 # building the menu contents until after we have the main window up (or until 700 # called for some). We do the same thing for the balloonhelp... 701 set wf [frame $glob(win,top).menu_frame] 702 # File menu 703 menubutton $wf.file_but\ 704 -menu $wf.file_but.m \ 705 -takefocus 0 \ 706 -text [_ "File"] 707 menu $wf.file_but.m -tearoff false\ 708 -font $glob(gui,GuiFont)\ 709 -postcommand [list buildFileMenu $wf] 710 # Configuration menu 711 menubutton $wf.configuration_but -takefocus 0 \ 712 -menu $wf.configuration_but.m \ 713 -text [_ "Configuration"] 714 set configmenu $wf.configuration_but.m 715 menu $configmenu -tearoff false\ 716 -font $glob(gui,GuiFont)\ 717 -postcommand [list buildConfigMenu $configmenu] 718 #======================= Here is the Motion work around ==================== 719 bind $wf.configuration_but <Motion> {+ 720 if {$::tk::Priv(postedMb) == "%W"} { 721 set ::tk::Priv(menuActivated) 1 722 } 723 } 724 #======================= End of the Motion work around ==================== 725 # Utilities menu 726 menubutton $wf.utils_but -takefocus 0\ 727 -menu $wf.utils_but.m\ 728 -text [_ "Utilities"] 729 menu $wf.utils_but.m -tearoff true \ 730 -tearoffcommand FixTearoff \ 731 -font $glob(gui,GuiFont)\ 732 -postcommand [list buildUtilsMenu $wf] 733 # Help menu 734 menubutton $wf.help_but\ 735 -takefocus 0\ 736 -menu $wf.help_but.m\ 737 -text [_ "Help"] 738 menu $wf.help_but.m \ 739 -tearoff false\ 740 -font $glob(gui,GuiFont)\ 741 -postcommand CreateHelpMenu 742 743 # Raised buttons 744 frame $wf.fasync_cmds -bd 0 745 # Stop button 746 button $wf.abort -takefocus 0 \ 747 -borderwidth 1 \ 748 -text [_ "Stop"] \ 749 -command {CmdAbort} 750 label $wf.async -text [_ "Async 0"] 751 # Clone button 752 # -state disabled \ 753 # button $wf.clone\ 754 # -takefocus 0\ 755 # -borderwidth 1\ 756 # -text [_ "Clone"]\ 757 # -command Clone 758 759 # Lay out the menus on the top of the window 760 label $wf.clock -text [Time] 761 # pack $wf.clock -side right 762 # Put in who we are and what machine... 763 if {!$::MSW} { 764 set user [exec whoami] 765 set host [expr {[info exists env(HOST)] ? $env(HOST) : \ 766 [info exist env(HOSTNAME)] ? $env(HOSTNAME) : "??"}] 767 } else { 768 set user $env(USERNAME) 769 set host [expr {[info exists env(COMPUTERNAME)] ? $env(COMPUTERNAME) : "??"}] 770 } 771 label $wf.user -text "$user@$host " 772 # Reserve our status line just below the menu bar 773 label $glob(win,top).status -relief groove -bd 2 -text {} -anchor e 774 # $wf.clone \ 775 # grid the menu line at the top... 776 set fixedLeft [list \ 777 $wf.file_but \ 778 $wf.configuration_but \ 779 $wf.utils_but \ 780 $wf.abort \ 781 $wf.async\ 782 $wf.fasync_cmds ] 783 set varRight [list \ 784 $wf.user \ 785 $wf.clock \ 786 $wf.help_but] 787 lappend ::startTimes [list [clock milliseconds] "Start griding main window"] 788 foreach win $fixedLeft { 789 grid $win -row 0 -column [incr col] -sticky w 790 } 791 foreach win $varRight { 792 grid $win -row 0 -column [incr col] -sticky e 793 } 794 # 795 grid columnconfigure $wf $fixedLeft -weight 0 796 grid columnconfigure $wf $col -weight 0; # help menu 797 grid columnconfigure $wf [incr col -1] -weight 1 ; # clock 798 grid columnconfigure $wf [incr col -1] -weight 100 ; # user 799 # Now the status line 800 grid $wf -sticky ew -row 2 801 grid $glob(win,top).status -row 4 -sticky ew 802 grid columnconfigure $glob(win,top) 0 -weight 1 803 # This completes the .fupper window, two lines 804 805 # Build the left and right panels 806 807 BuildFileListPanel left 808 BuildFileListPanel right 809 lappend ::startTimes [list [clock milliseconds] "After list Panel build"] 810 811 set glob(selectFileList) {} 812 # This window is NEVER displayed. It is only used to pass the selection 813 # to the window system. 814 set glob(selectWindow) [listbox .fupper.selectTex \ 815 -listvariable glob(selectFileList)]\ 816 817 # build widget .fm 818 # The "width" below is overridden later, but here now because 819 # we want this window to be near the right size when it shows 820 # during start up. Orange is just a debug feature so we know 821 # what window we are looking at. 822 set wc [canvas .fupper.can -background orange -width 0] 823 set glob(win,can) $wc 824 set wm [frame $glob(win,middle) ] ; # -background gold 825 # 826 827 set glob(cmds,cur) 0 828 829 set wscr [frame .fupper.scroll -borderwidth 0 -relief raised] 830 buttonWbitmap $wscr.up \ 831 -relief raised \ 832 -borderwidth 1\ 833 -command "whatDoesTheFoxSay $wc -1" \ 834 {*}[getImage -bitmap pgup @$glob(lib_fr)/bitmaps/pgup.bit] 835 836 837 buttonWbitmap $wscr.down \ 838 -relief raised \ 839 -borderwidth 1\ 840 {*}[getImage -bitmap pgdown @$glob(lib_fr)/bitmaps/pgdown.bit]\ 841 -command "whatDoesTheFoxSay $wc 1" 842 843 844 # the <- -> middle buttons... 845 set c [lindex $glob(cmds,list) 0] 846 set n 1 847 frame $wm.$n -bd 0 ; # -background red 848 frame $wscr.fs -bd 0 849 incr n 850 set c [lindex $glob(cmds,list) 1] 851 foreach inst {left right} { 852 buttonWbitmap $wscr.$inst \ 853 -relief raised \ 854 -borderwidth 1\ 855 {*}[getImage -bitmap $inst @$glob(lib_fr)/bitmaps/$inst.bit] \ 856 -command "DoProtCmd CmdTo$inst" 857 858 # buttonWbitmap $wscr.left \ 859 # -relief raised \ 860 # -borderwidth 1\ 861 # {*}[getImage -bitmap left @$glob(lib_fr)/bitmaps/left.bit]\ 862 # -command "DoProtCmd CmdToleft" 863 864 button $wscr.fs.$inst \ 865 -command "DoProtCmd ColTo$inst" \ 866 {*}[getImage -bitmap small-$inst\ 867 @$glob(lib_fr)/bitmaps/small-$inst.bit] 868 869 870 # button $wscr.fs.left \ 871 # -command "DoProtCmd ColToleft" \ 872 # {*}[getImage -bitmap small-left\ 873 # @$glob(lib_fr)/bitmaps/small-left.bit] 874 } 875 button $wscr.fs.mid \ 876 -command "DoProtCmd ToggleCollock"\ 877 {*}[getImage -bitmap lock\ 878 @$glob(lib_fr)/bitmaps/lock.bit] 879 880 #$wscr config -height [winfo reqheight $wscr.up] 881 grid $wscr.up $wscr.down -row 1 -sticky nsew 882 grid $wscr.left $wscr.right -row 2 -sticky nsew 883 grid $wscr.fs.left $wscr.fs.mid $wscr.fs.right -sticky nsew 884 grid $wscr.fs -row 3 -columnspan 2 -sticky ew 885 grid columnconfigure $wscr all -weight 1 886 grid columnconfigure $wscr.fs all -weight 1 887 888 grid columnconfigure $wm all -weight 1 889 890 $wc create window 0 0 -window $wm -anchor nw 891 892 #grid columnconfigure $glob(win,bottom) all -weight 0 893 grid columnconfigure $glob(win,bottom) all -weight 0 894 grid columnconfigure $glob(win,bottom) 0 -weight 1 895 grid .fupper -sticky news -row 2 896 grid propagate .fupper 0 897 898 lappend ::startTimes [list [clock milliseconds] "Start CmdWindow build"] 899 900 BuildCmdWindow left 901 BuildCmdWindow right 902 lappend ::startTimes [list [clock milliseconds] "After CmdWindow build"] 903 # Grid the top window "." 904 grid rowconfigure . 2 -weight 1 905 grid columnconfigure . all -weight 1 906 # grid $glob(win,bottom) -sticky news -row 6 907 # By using the grid routine we can force the middle buttons to stay 908 # after all else is gone (well that is better than loosing them early 909 # when the window width is decreased. We also keep the two list widths 910 # balanced. 911 grid $glob(win,top) -column 0 -columnspan 3 -row 0 -sticky ew 912 grid $glob(win,left) -column 0 -rowspan 2 -row 1 -sticky nsew 913 grid $wscr -column 1 -columnspan 1 -row 1 -sticky news 914 grid $wc -column 1 -row 2 -sticky news 915 grid $glob(win,right) -column 2 -rowspan 2 -row 1 -sticky nsew 916 grid rowconfigure .fupper all -weight 0 917 grid rowconfigure .fupper $wc -weight 1 918 grid columnconfigure .fupper all -weight 1 919 grid columnconfigure .fupper $wc -weight 0 920 921 922 # grid remove $glob(win,bottom) 923 set glob(TraceColToEnabled) 0 924 set glob(panelsLocked) \ 925 [expr {$config(ListBoxColumns,left) != $config(ListBoxColumns,right)}] 926 ToggleCollock 927 trace add variable config(ListBoxColumns,left) write \ 928 "after idle {TraceColTo left right}" 929 trace add variable config(ListBoxColumns,right) write \ 930 "after idle {TraceColTo right left}" 931} 932 933 934# This bit gets called after reading a new config file. It fixes/sets up 935# the stuff that depends on config options. 936# It needs to be able to be re-executed each time we read config 937 938proc postConfigShow {} { 939 global glob config win fast_checkboxes 940 # proc what {in } { puts "$in"} 941 Log "glob(init_done) $glob(init_done)" 942 if {!$glob(init_done)} { 943 # don't do this except on initial load 944 lassign [split [getGeo $config(geometry,main) .] x+] W H X Y 945 # check if we are to do other 946 set mon [::displays::get {*}[winfo pointerxy .]] 947 frputs mon 948 Log "mon $mon" 949 switch -glob $config(geometry,mainops) { 950 ra* {wm geo . ${W}x${H} } 951 re* { 952 set mon2 [::displays::get $X $Y] 953 if {$mon2 != $mon} { 954 set X [expr {$X - [lindex $mon2 0] + [lindex $mon 0]}] 955 set Y [expr {$Y - [lindex $mon2 2] + [lindex $mon 2]}] 956 } 957 wm geo . ${W}x${H}+${X}+$Y 958 } 959 c* {centerWin . $mon} 960 a* - 961 default {wm geo . ${W}x${H}+${X}+$Y } 962 } 963 wm att . -al 1.0 964 } 965 set n 0 966 set w $glob(win,top).menu_frame.fasync_cmds 967 set savcon 0 968 set newConfig {} 969 # A paranoid check. If the length is not exactly 4, remove it. 970 foreach ent $config(fast_checkboxes) { 971 if {[llength $ent] != 4} {continue} 972 lappend newConfig $ent 973 } 974 set config(fast_checkboxes) $newConfig 975 set newConfig {} 976 # Make sure all fast_checkbox buttons appear in the list. 977 # Add any missing ones at the end and disabled. 978 foreach fcb $fast_checkboxes { 979 set nam [lindex $fcb 0] 980 if {[lsearch -exact -index 0 $config(fast_checkboxes) $nam] == -1} { 981 lappend config(fast_checkboxes) [list $nam $nam d \ 982 [subst [lindex $fcb 3]]] 983 incr savcon 984 frputs savcon 985 } 986 } 987 #puts "added $savcon fast check boxes" 988 set deletedFCB "The following \"check box\" entries have \ 989 \nbeen removed from config(fast_checkboxes):" 990 foreach k $config(fast_checkboxes) { 991 destroy $w.$n 992 if {[set kn [lsearch -index 0 -exact \ 993 $fast_checkboxes [lindex $k 0]]] != -1 } { 994 #puts "$k [lindex $k 2]" 995 if { [lindex $k 2] != "d" } { 996 set kk [lindex $fast_checkboxes $kn] 997 lassign [lindex $kk 2] var onVal offVal initVal 998 set onVal [expr {$onVal == {} ? 1 : $onVal}] 999 set offVal [expr {$offVal == {} ? 0 : $offVal}] 1000 #puts "$w.$n checkbox [lindex $k 1] $var $onVal $offVal" 1001 checkbutton $w.$n -takefocus 0 -variable $var \ 1002 -text "[lindex $k 1]" \ 1003 -onvalue $onVal \ 1004 -offvalue $offVal \ 1005 -command "[lindex $kk 1]" 1006 # -selectcolor #fffffe 1007 balloonhelp_for $w.$n [lindex $kk 3] 1008 grid $w.$n -row 0 -column [incr col] 1009 # if an initial value is provided, set up oppsit and invoke 1010 if {$initVal != {}} { 1011 set [set var] [expr {$initVal == $offVal ? $onVal : $offVal}] 1012 $w.$n invoke 1013 } 1014 incr n 1015 } 1016 if {[lsearch -index 0 -exact $newConfig [lindex $k 0]] == -1} { 1017 lappend newConfig $k 1018 } 1019 } else { 1020 # this config entry was not found in our list, we 1021 # drop it with a PopWarn later... 1022 # but it does mean we need to save the new one 1023 # puts "marked $k for delete" 1024 set someDeleted 1 1025 append deletedFCB "\n[lindex $k 0]" 1026 set savcon 1 1027 frputs savcon 1028 } 1029 } 1030 set config(fast_checkboxes) $newConfig 1031 lappend ::startTimes [list [clock milliseconds] "After checkbox set up "] 1032 1033 # Middle button management. There are 3 sources of middle 1034 # buttons: 1035 # 1) glob(cmds,list) (The built in commands) 1036 # 2) config(usercommands) (Built as defined in the "User's Guide") 1037 # 3) config(userButton,*) (Configured in the configuration script) 1038 # 1039 # All buttons appear (or will appear) in the config(middle_button_list) 1040 # which defines the order used in the middle button column. 1041 # If a button is not in config(middle_button_list) it is added at the 1042 # end and is enabled (so the user is aware of it) 1043 # On type 3: 1044 # The button name will be what ever is used for "*". The label text 1045 # will be either the "label <text>" or the name with the first char. 1046 # in caps. The button name is passed to the command so it can access 1047 # the config info. 1048 1049 # Purge old user commands from the cmds,list 1050 while {[lindex $glob(cmds,list) end 1 0] in {DoUsrCmd DoUsrButton}} { 1051 set glob(cmds,list) [lreplace $glob(cmds,list) end end] 1052 } 1053 # Now add the new set 1054 set foo {} 1055 set butMess {} 1056 # the following code makes sure that the config button list is complete 1057 # missing entries are supplied as disabled. 1058 foreach cmd $glob(cmds,list) { 1059 # localize to commpare with config which has to be localized... 1060 set text [_ [lindex $cmd 0]] 1061# puts "[lindex $cmd 0] $cmd " 1062 if {[lsearch -index 0 -exact $config(middle_button_list) $text] == -1 } { 1063 lappend config(middle_button_list) [list $text ] 1064 lappend foo $text 1065 set savcon 1 1066 # puts "savcon 1" 1067 } 1068 } 1069 # This cleans any entries in the config button list that we don't know 1070 # about. 1071 set userButtons {} 1072 foreach {name val} [array get config "userButton,*"] { 1073 lappend userButtons [string range $name 11 end] 1074 } 1075 foreach cmd $config(middle_button_list) { 1076 set cmd0 [lindex $cmd 0] 1077 if {[lsearch -exact -index 0 $config(usercommands) $cmd0] != -1} { 1078 lappend newcmds $cmd 1079 continue 1080 } 1081 set incmdslist 0 1082 foreach ent $glob(cmds,list) { 1083 set text [_ [lindex $ent 0]] 1084 #puts "testing $text<>[lindex $cmd 0]" 1085 if {$cmd0 == $text } { 1086 #puts "yes $text" 1087 lappend newcmds $cmd 1088 set incmdslist 1 1089 break 1090 } 1091 } 1092 if {!$incmdslist && $cmd in $userButtons} { 1093 lappend newcmds $cmd 1094 } 1095 } 1096 # Use lnorm to prevent white space from messing with the compare. 1097 if {[lnorm $config(middle_button_list)] != $newcmds} { 1098 set config(middle_button_list) $newcmds 1099 set savcon 1 1100 # puts "savcon 2" 1101 } 1102 set foobar {} 1103 foreach k $config(usercommands) { 1104 lappend foobar [list [lindex $k 0] \ 1105 [list DoUsrCmd [lindex $k 1]] \ 1106 {} {} \ 1107 [lindex $k 2]] 1108 } 1109 foreach k $userButtons { 1110 lappend foobar [list $k [list DoUsrButton $k]] 1111 } 1112 foreach k $foobar { 1113 if {[lsearch -index 0 -exact $config(middle_button_list) \ 1114 [lindex $k 0]] == -1 } { 1115 lappend config(middle_button_list) [lindex $k 0] 1116 lappend foo [lindex $k 0] 1117 set savcon 1 1118 # puts "savcon 3" 1119 } 1120 } 1121 if {$foo != {}} { 1122 set butMess "Added these buttons:\n" 1123 foreach but $foo { 1124 append butMess "\"$but\" " 1125 } 1126 append butMess "\nto the middle button list" 1127 set foo {} 1128 } 1129 if {$savcon != 0} { 1130 #puts "saving new config" 1131 SaveConfig 1132 lappend ::startTimes [list [clock milliseconds] "After save Config "] 1133 } 1134 set glob(cmds,list) [concat $glob(cmds,list) $foobar] 1135 set n 1 1136 set wc $glob(win,can) 1137 set wm $glob(win,middle) 1138 for {set nn $n} \ 1139 {$nn <= [expr {2 * [llength $config(middle_button_list)]}]} \ 1140 {incr nn} { 1141 destroy $wm.$nn 1142 } 1143 # build a translated glob(cmds,list) to speed searching... 1144 foreach cmd $glob(cmds,list) { 1145 lappend tCmds [_ [lindex $cmd 0]] 1146 } 1147 lappend ::startTimes [list [clock milliseconds] "Begin build middle buttons "] 1148 # button entry list can have 1, 2 or 3 entries 1149 # The first MUST be the formal button name 1150 # 1151 set glob(winButName) {} 1152 foreach b $config(middle_button_list) { 1153 lassign $b name dtxt disable 1154 if {$disable != "d" && ($disable != {} || $dtxt != "d")} { 1155 set cc [lsearch -exact $tCmds $name] ;#[lindex $b 0]] 1156 #puts "$b<>[lindex $b 0] is index $cc" 1157 if { $cc != -1 } { 1158 # Found it. 1159 set c [lindex $glob(cmds,list) $cc] 1160# puts "doing button [lindex $c 0]" 1161 # if the middle_button_list has a display name... 1162 # userButtons have the display name somewhat hidden 1163 if {[lindex $c 1 0] == "DoUsrButton"} { 1164 set dtxt [string totitle $name] 1165 foreach {key value} $config(userButton,$name) { 1166 if {[string match "l*" $key]} { 1167 set dtxt $value 1168 break 1169 } 1170 } 1171 } 1172 set text [expr {$dtxt == {} ? [_ [lindex $c 0]] : $dtxt}] 1173 button $wm.$n -text $text -command \ 1174 "set glob(mbutton) 1; DoProtCmd \"[lindex $c 1]\"" 1175 balloonhelp_for $wm.$n [expr {[lindex $c 4] == {} ? \ 1176 "No help for $text" : [lindex $c 4]}] 1177 set kc [lindex $c 2] 1178 if {$kc != "" && $config(keyb_support)} { 1179 # The char # was based on the orgional name.. 1180 # See if we have such a char now 1181 # find caps first.. 1182 set kcU [string toupper $kc] 1183 set uc [string first $kcU $text] 1184 if {$uc == -1} { 1185 set uc [string first $kc $text] 1186 } 1187 if {$uc != -1} { 1188 $wm.$n configure -underline [lindex $c 3] 1189 } 1190 } 1191 # colors in 'middle_button_colors are indexed by button name 1192 # which is, well, lost once we leave this loop so 1193 # save them... 1194 lappend glob(winButName) $wm.$n $name 1195 1196 # Windows does not activate a button when the mouse enters 1197 # We effort to fix that WRT color. 1198 bind $wm.$n <Enter> +[list doButColor $wm.$n -activebackground] 1199 bind $wm.$n <Leave> +[list doButColor $wm.$n -highlightbackground] 1200 1201 bind $wm.$n <ButtonRelease-3> "set glob(mbutton) 2 1202 set glob(async) {-a} 1203 DoProtCmd \"[lindex $c 1]\"" 1204 bind $wm.$n <ButtonRelease-2> "set glob(mbutton) 3 1205 DoProtCmd \"[lindex $c 1]\"" 1206 grid $wm.$n -row $n -sticky ew 1207 #pack $wm.$n -side top -fill x 1208 incr n 1209 } 1210 } 1211 } 1212 lappend ::startTimes [list [clock milliseconds] "End build middle buttons "] 1213 # update idletasks 1214 set i 1 1215 while {$i < $n} { 1216 bind $wm.$i <MouseWheel> "whatDoesTheFoxSay $wc -%D;break" 1217 bind $wm.$i $config(mwheel,neg) "whatDoesTheFoxSay $wc -1 ;break" 1218 bind $wm.$i $config(mwheel,pos) "whatDoesTheFoxSay $wc 1 ;break" 1219 incr i 1220 } 1221 set glob(cmds,number) $n 1222 # buttoncmds are possible bindings for the three mouse presses on dir 1223 # listings. 1224 foreach c $glob(cmds,list) { 1225 set name [_ [lindex $c 0]] 1226 switch -regexp $name { 1227 ^[[:alnum:]].* { 1228 lappend glob(middlebuttoncmds) [list [_ [lindex $c 0]] \ 1229 [lindex $c 1] [lindex $c 4]] 1230 } 1231 } 1232 } 1233 setMidButColor 1234 # we need this wait to get good info on heigth and width 1235 lappend ::startTimes [list [clock milliseconds] "After wait for button info "] 1236 1237 if {![info exists someDeleted] || !$someDeleted} { 1238 set deletedFCB {} 1239 } 1240 # set glob(TraceColToEnabled) 1 1241 # if {$config(ListBoxColumns,left) !=\ 1242 # $config(ListBoxColumns,right)} { 1243 # TraceColTo left right 1244 # } 1245 return [list $deletedFCB $butMess] 1246} 1247# We put the following here to be called later when (we hope) 1248# the windows are well enough defined that winfo will return 1249# correct information. With out a delay, the middle column is 1250# too narrow and too long. 1251proc finishButtonScroll {} { 1252 global glob 1253 set wc $glob(win,can) 1254 set wm $glob(win,middle) 1255 set rq [winfo reqheight $wm] 1256 $wc config -scrollregion [list 0 0 0 $rq] \ 1257 -width [winfo reqwidth $wm]\ 1258 -yscrollincrement [winfo reqheight $wm.1] 1259} 1260# ====================== End of post config show =================== 1261 1262proc doButColor {w which} { 1263 $w config -bg [$w cget $which] 1264} 1265 1266proc setMidButColor {} { 1267 global glob config 1268 foreach {w name} $glob(winButName) { 1269 set indx [lsearch -exact -index 0 -all $config(middle_button_colors) $name] 1270 if {$indx == -1} {continue} 1271 foreach ind $indx { 1272 foreach color [lrange [lindex $config(middle_button_colors) $ind] 1 end] { 1273 if { [string index $color 0] == "-" } { 1274 $w configure -activebackground [set color [string range $color 1 end]] 1275 } else { 1276 $w configure -background $color\ 1277 -activebackground [LighterColor2 $color]\ 1278 -highlightbackground $color 1279 } 1280 } 1281 } 1282 } 1283} 1284 1285# This function decides if it it cool to pass a scroll request to the 1286# window this function is designed to catch a problem of scrolling down 1287# such that the top is below zero (a canvas scroll issue) 1288proc whatDoesTheFoxSay {w scr {scrinc 1}} { 1289 set scr [regsub -- {--} $scr {}] 1290 set scrin [expr {$scr < 0 ? -$scrinc : $scrinc}] 1291 #Log "the fox says $scr $scrin [$w yview]" 1292 if {$scr < 0 && [lindex [$w yview] 0] == "0.0"} { 1293 $w yview moveto 0.0 1294 } else { 1295 $w yview scroll $scrin units 1296 } 1297} 1298 1299proc ToggleCollock {} { 1300 global glob config 1301 set w .fupper.scroll.fs 1302 # only do something if eq/neq button is psudo enabled 1303 if {[$w.mid cget -wraplength]} {return} 1304 if {$glob(panelsLocked)} { 1305 set glob(panelsLocked) 0 1306 foreach inst {right left} { 1307 if {[$w.$inst cget -wraplength]} { 1308 $w.$inst conf -wraplength 0 -image \ 1309 [string range [$w.$inst cget -image] 0 end-1] 1310 } 1311 # if {[$w.left cget -wraplength]} { 1312 # $w.left conf -wraplength 0 -image \ 1313 # [string range [$w.left cget -image] 0 end-1] 1314 # } 1315 } 1316 $w.mid conf {*}[getImage -bitmap unlock \ 1317 @$glob(lib_fr)/bitmaps/unlock.bit] 1318 } else { 1319# if {$config(ListBoxColumns,left) != $config(ListBoxColumns,right) } {} 1320 set glob(panelsLocked) 1 1321 foreach inst {right left} { 1322 $w.$inst conf -wraplength 1\ 1323 {*}[getImage bitmap small-${inst}c\ 1324 -file $glob(lib_fr)/bitmaps/small-$inst.bit\ 1325 -foreground $config(gui,color_highlight_fg)] 1326 # $w.left conf -wraplength 1\ 1327 # {*}[getImage bitmap small-leftc\ 1328 # -file $glob(lib_fr)/bitmaps/small-left.bit\ 1329 # -foreground $config(gui,color_highlight_fg)] 1330 } 1331 $w.mid conf -wraplength 0\ 1332 {*}[getImage -bitmap lock\ 1333 @$glob(lib_fr)/bitmaps/lock.bit] 1334 } 1335} 1336 1337proc ColToleft {} { 1338 ColTo right left 1339} 1340 1341proc ColToright {} { 1342 ColTo left right 1343} 1344proc ColTo { from to args} { 1345 # puts "ColTo $from $to $args" 1346 # setupDebug 1 1347 #frputs #1 #2 #3 1348 global glob config 1349 if {$config(ListBoxColumns,left) != $config(ListBoxColumns,right)} { 1350 set config(ListBoxColumns,$to) $config(ListBoxColumns,$from) 1351 # $glob(listbox,$to) 1352 set w .fupper.scroll.fs.mid 1353 if {[$w cget -wraplength]} { 1354 $w conf -wraplength 0\ 1355 -image [string range [$w cget -image] 0 end-1] 1356 } 1357 buildListBox $to 1358 # wait for the dust to settle... 1359 update idletasks 1360 ReConfigColors foo 1361 ReConfigFont 1362 } 1363} 1364 1365# This gets called when the list box colums are changed. 1366proc TraceColTo { from to args} { 1367 global glob config 1368 if {!$glob(TraceColToEnabled)} {return} 1369 set glob(TraceColToEnabled) 0 1370 if {$glob(panelsLocked)} { 1371 ColTo $from $to 1372 } else { 1373 set nstate [expr {$config(ListBoxColumns,left) !=\ 1374 $config(ListBoxColumns,right)}] 1375 # we keep the logical state in wraplength as disable messes 1376 # with the image 1377 # 1 is disabled and we display the colored image which must be not-eq 1378 set image [lindex [getImage bitmap unlockc\ 1379 -file $glob(lib_fr)/bitmaps/unlock.bit\ 1380 -foreground $config(gui,color_highlight_fg)]\ 1381 1] 1382 if {!$nstate} { 1383 # color images have a "c" added to the end of the name 1384 set image [string range $image 0 end-1] 1385 } 1386 .fupper.scroll.fs.mid conf -wraplength $nstate \ 1387 -image $image 1388 } 1389 set glob(TraceColToEnabled) 1 1390} 1391 1392# ================================ Color and Font stuff =============== 1393proc EditColor { color } { 1394 global config glob 1395 set c $glob(gui,$color) 1396 if {$c == ""} {set c [set glob(gui,$color) grey85]} 1397 ColorEditor $color "global glob;\ 1398 set glob(gui,$color) %%;ReConfigColors" $c $config(gray) 1399} 1400 1401proc DoEditFont {} { 1402 set newGui [EditFont ListBoxFont] 1403 if {$newGui != 0} { 1404 SaveConfig 1405 } 1406 if {$newGui > 1} { 1407 ReadConfig 1408 } 1409} 1410 1411proc ReConfigFont {} { 1412 global glob config 1413 if {$glob(gui,GuiFont) == "" } { 1414 set $glob(gui,GuiFont) $config(gui,GuiFont) 1415 } 1416 catch {tk_setFont $glob(gui,GuiFont)} out 1417 # set glob(gui,GuiFont) $config(gui,GuiFont) 1418 1419 # if {$config(gui,ListBoxFont) != $glob(gui,ListBoxFont)} {} 1420 foreach k $glob(winlist,color_xx) { 1421 catch {$k configure -font $glob(gui,ListBoxFont)} 1422 } 1423 foreach inst {left right} { 1424 setListBoxFont $glob(listbox,$inst) {$glob(gui,ListBoxFont)} 1425 } 1426 foreach class {Entry Text Listbox} { 1427 option add *$class.Font $glob(gui,ListBoxFont) 1428 } 1429 set glob(gui,ListBoxFont) $glob(gui,ListBoxFont) 1430 foreach w [list $glob(win,top).status \ 1431 $glob(win,left).top.stat \ 1432 $glob(win,right).top.stat] { 1433 $w config -font $glob(gui,ListBoxFont) 1434 } 1435 # balloon window may not have been set up yet... 1436# catch {set ::balloon_help::font $glob(gui,BalloonHelpFont)} 1437 balloon_help_config font $glob(gui,BalloonHelpFont) 1438 #{ } 1439} 1440 1441# Arguments: 1442# color - Name of starting color. 1443# perecent - Integer telling how much to brighten or darken as a 1444# percent: 50 means darken by 50%, 110 means brighten 1445# by 10%. Default is lighter by 15%. 1446# (shamelessly adapted from tk::Darken) 1447 1448proc LighterColor { color {percent 115}} { 1449 lassign [winfo rgb . $color] r g b 1450 set p [expr {$percent / 100.}] 1451 foreach i {rr gg bb} c [winfo rgb . $color] { 1452 set $i [expr {int(($c/256) * $p)}] 1453 if {[set $i] > 255} { 1454 set $i 255 1455 } 1456 } 1457 return [format #%02x%02x%02x $rr $gg $bb] 1458} 1459# 1460# In this version we use an absolute value (i.e. a % of the full range 1461# rather than the current value) 1462 1463proc LighterColor2 { color {percent 115}} { 1464 lassign [winfo rgb . $color] r g b 1465 set p [expr {$percent < 100 ? -$percent * 2.56 : ($percent - 100) *2.56}] 1466 foreach i {rr gg bb} c [winfo rgb . $color] { 1467 set $i [expr {int(($c/256) + $p)}] 1468 if {[set $i] > 255} { 1469 set $i 255 1470 } 1471 if {[set $i] < 0} { 1472 set $i 0 1473 } 1474 } 1475 return [format #%02x%02x%02x $rr $gg $bb] 1476} 1477 1478 1479# The following is shamelessly lifted from tk_setPalette which we 1480# don't use because we only want to do selected widgets, by class 1481 1482proc makePalette {bg cnames result {fg {}}} { 1483 upvar $result new 1484 upvar $cnames colornames 1485 1486 # we build these color names: 1487 set colornames [list foreground background selectBackground troughColor \ 1488 highlightBackground activeForeground selectForeground \ 1489 selectColor highlightColor disabledForeground \ 1490 activeBackground ] 1491 1492 lassign [winfo rgb . $bg] bg_r bg_g bg_b 1493 # r g & b range 0-65535 and your eyes are more sensitive to 1494 # green than to red, and more to red than to blue. 1495 set new(background) $bg 1496 set new(foreground) $fg 1497 if {$fg == {}} { 1498 # foreground will be either black or white depending on 1499 # perceived brightness of the bg. 1500 if {$bg_r+1.5*$bg_g+0.5*$bg_b > 100000} { 1501 set new(foreground) black 1502 } else { 1503 set new(foreground) white 1504 } 1505 } 1506 set new(selectBackground) \ 1507 [format #%02x%02x%02x [expr {(9*$bg_r)/2560}] \ 1508 [expr {(9*$bg_g)/2560}] [expr {(9*$bg_b)/2560}]] 1509 1510 # do we need this???? 1511 set new(troughColor) $new(selectBackground) 1512 set new(highlightBackground) $new(background) 1513 foreach i {activeForeground \ 1514 selectForeground highlightColor} { 1515 set new($i) $new(foreground) 1516 } 1517 lassign [winfo rgb . $new(foreground)] fg_r fg_g fg_b 1518 ## ?? 1519 set new(disabledForeground) [format #%02x%02x%02x \ 1520 [expr {(3*$bg_r + $fg_r)/1024}] \ 1521 [expr {(3*$bg_g + $fg_g)/1024}] \ 1522 [expr {(3*$bg_b + $fg_b)/1024}]] 1523 set new(activeBackground) [LighterColor2 $bg] 1524 set new(selectColor) $new(activeBackground) 1525 return 1526} 1527 1528# colorBaseLine is basically a been here for each color. 1529# we set it to the given color as we do the work of updateing each. 1530# If args != {} we do all the colors, otherwise only those that differ 1531# from the baseLine (or if the baseLine does not yet exist. 1532 1533proc ReConfigColors {args} { 1534 global glob config beenHere colorBaseLine 1535 unset -nocomplain beenHere 1536 set do {} 1537 foreach c {color_scheme color_bg color_fg color_select_bg\ 1538 color_select_fg color_cursor color_cmd \ 1539 color_highlight_fg color_highlight_bg \ 1540 color_balloonHelp_fg color_balloonHelp_bg\ 1541 color_handle} { 1542 if {![info exist colorBaseLine($c)] ||\ 1543 $colorBaseLine($c) != $glob(gui,$c) || \ 1544 $args != {} || \ 1545 $c in $do} { 1546 switch $c { 1547 color_scheme { 1548 set Cl {Button Checkbutton Menubutton Radiobutton Canvas 1549 Scrollbar Label Menu Frame Scale Dialog} 1550 makePalette $glob(gui,$c) cols new 1551 foreach cl $cols { 1552 setOptionF $Cl [list .tkcon.* *Tear*] $cl $new($cl) 1553 } 1554 # gui exceptions... here we undo what we want different 1555 1556 # bit of a conflict between the Menu and the Checkbutton/Radiobutton 1557 setOptionF Menu [list .tkcon.* *Tear*] selectColor $new(foreground) 1558 # set the special middle button colors, if any 1559 setMidButColor 1560 # let the other color sections take the Label and handles.. 1561 # this line requires that 'color_scheme' is before these int 1562 # the foreach loop. 1563 lappend do color_fg color_bg color_handle 1564 } 1565 color_bg { 1566 frputs glob(gui,$c) 1567 setOption background $glob(gui,$c) 1568 doWidget .fupper Label [list .fupper.ftop* .fupper.*.top.s* .tkcon.*] $args\ 1569 "\[set wd] config -background $glob(gui,$c)" 1570 } 1571 1572 color_fg { 1573 setOption foreground $glob(gui,$c) 1574 doWidget .fupper Label [list .fupper.ftop* .fupper.*.top.s* .tkcon.* ] $args\ 1575 "\[set wd] config -foreground $glob(gui,$c)" 1576 } 1577 1578 color_select_fg { 1579 setOption {selectForeground activeForeground} $glob(gui,$c) 1580 foreach inst {left right} { 1581 $glob(win,bottom).fcmdwin$inst.text tag config complete \ 1582 -foreground $glob(gui,$c) 1583 } 1584 } 1585 1586 color_select_bg { 1587 setOption {selectBackground activeBackground inactiveSelectBackground}\ 1588 $glob(gui,$c) 1589 foreach inst {left right} { 1590 $glob(win,bottom).fcmdwin$inst.text tag config complete \ 1591 -background $glob(gui,$c) 1592 } 1593 } 1594 color_cursor {setOption insertBackground $glob(gui,$c)} 1595 color_cmd { 1596 foreach inst {left right} { 1597 $glob(win,bottom).fcmdwin$inst.text tag config command \ 1598 -background $glob(gui,$c) 1599 } 1600 } 1601 color_highlight_fg - 1602 color_highlight_bg { 1603 if {$glob(select_pry_lr) != {}} { 1604 twidleHighlight $glob(select_pry_lr) on $glob(select_pry_s) 1605 } 1606 setOption [expr {$c == "color_highlight_fg" ? "highlightColor" : \ 1607 "highlightBackground"}] $glob(gui,$c) 1608 } 1609 color_balloonHelp_fg {balloon_help_config fg $glob(gui,$c)} 1610 color_balloonHelp_bg {balloon_help_config bg $glob(gui,$c)} 1611 color_handle { 1612 $glob(listbox,left) config -bg $glob(gui,color_handle) 1613 $glob(listbox,right) config -bg $glob(gui,color_handle) 1614 } 1615 } 1616 } 1617 set colorBaseLine($c) $glob(gui,$c) 1618 } 1619 1620} 1621 1622proc setOption {ops val} { 1623 setOptionF {Entry Listbox Text} [list .tkcon.* *Tear*] $ops $val 1624} 1625 1626proc setOptionF {class except ops val} { 1627 foreach op $ops { 1628 foreach clas $class { 1629 # frputs clas op val 1630 option add *$clas.$op $val 90 1631 # puts "set option *$class.$op $val" 1632 } 1633 doWidget . $class $except {}\ 1634 "\[set wd] config -[string tolower $op] $val" 1635 } 1636} 1637 1638# This function executes the passed in script on each widget in the process 1639# that is in the given class list and not in the given except list 1640# It keeps a list of the qualifying windows so any subsequent run is 1641# faster. 1642 1643proc doWidget {w class except new args} { 1644 global glob 1645 if {![info exists beenHere($w,$class)] || $new == {}} { 1646 set beenHere($w,$class) [BuildSelectWidgetList $w $class $except] 1647 } else { 1648 # frputs "doWidget HAVE list for $w,$class " 1649 } 1650 foreach wd $beenHere($w,$class) { 1651 foreach arg $args { 1652 set r [catch "eval $arg" out] 1653 # # debug only.... 1654 # if {$r == 0 && [catch "$wd config -bitmap" out] == 0 && [lindex $out 4] != {} } { 1655 # puts "Changing $wd: [lindex $out 4]<>$arg" 1656 # } 1657 # # end debug 1658 } 1659 } 1660} 1661 1662 1663proc BuildSelectWidgetList {wd class except} { 1664 set rtn {} 1665 if {[patternListSearch $except $wd] == {} && [winfo class $wd] in $class} { 1666 lappend rtn $wd 1667 } 1668 foreach ch [winfo child $wd] { 1669 set srtn [BuildSelectWidgetList $ch $class $except] 1670 if {$srtn != {} } { 1671 lappend rtn {*}$srtn 1672 } 1673 } 1674 return $rtn 1675} 1676# ============================= End of the Color and Font management stuff ====== 1677 1678# 'linux wish +source' 'linux fr' 'win wrap' 'win wish +source' 1679# info nameofex fpt wish fpt wish fr.exe fpt wish 1680# argv0 ? wish ? fr \fr.exe fpt wish 1681# glob(program) ? fr fpt fr wrap p fr fpt fr 1682# 1683proc Clone {} { 1684 global glob argv argv0 1685 cd $glob(start_path) 1686 set target [file normalize [info nameofex]] 1687 set script [file norm [file join $glob(start_path) $glob(program)]] 1688 if {([file extension $target] == ".exe" && \ 1689 [string match -nocase *fr* [file tail $target]]) || \ 1690 $target == $script } { 1691 set script "" 1692 } 1693 frECF {exec %b &} [list $target $script $glob(left,pwd) $glob(right,pwd)] 1694 1695} 1696 1697# ======================== Command window stuff ========================== 1698 1699proc ToggleCmdWin { inst } { 1700 global glob config 1701 set w $glob(win,bottom).fcmdwin$inst 1702 if {$glob($inst,shell,grided)} { 1703 grid remove $w 1704 if {!$glob([Opposite $inst],shell,grided)} { 1705 grid remove $glob(win,bottom) 1706 } 1707 set glob($inst,shell,grided) 0 1708 set glob($inst,shell,history,flipping) 0 1709 } else { 1710 if {!$glob([Opposite $inst],shell,grided)} { 1711 grid $glob(win,bottom) -sticky news -row 6 1712 } 1713 $w.text configure -height $config(shell,height,$inst) 1714 set glob($inst,shell,maxed) 0 1715 grid $w -column 0 -sticky news -row [expr {$inst == "left" ? 10 : 20}] 1716 # grid rowconfig $w $w.text -weight 1 1717 # grid rowconfig $w $w.bot -weight 0 -minsize 22 1718 set glob($inst,shell,grided) 1 1719 } 1720 update 1721 # grid command seems to forget this so we remind it. 1722 grid rowconfigure . 2 -weight 1 1723} 1724 1725proc MaxWin {inst } { 1726 global glob config 1727 if {$glob($inst,shell,maxed)} { 1728 $glob(win,bottom).fcmdwin$inst.text configure \ 1729 -height $config(shell,height,$inst) 1730 set glob($inst,shell,maxed) 0 1731 } else { 1732 # $glob(win,bottom).fcmdwin$inst.text configure -height 2000 1733 MaxCmdText $inst 1734 #set glob($inst,shell,maxed) 1 1735 } 1736} 1737 1738# It seems that pack use to do this for us, but grid, not so much 1739# This routine computes and adjusts the given command window such 1740# that the command line will always be displayed. If the result is 1741# less than 1, it tries to take from the other command window 1742# (if it is open). This needs to be called when ever the command 1743# line is obscured. This may happen as a result of resizing 1744# either the main window or the command window. 1745# The total size of the text part of the command window must be 1746# less than: Main-window - other-cmd - bottom - bd of cmd and text 1747 1748 1749proc MaxCmdText {inst {rq 0}} { 1750 global glob config 1751 # rq is true if this is the result of pushing the button larger button 1752 1753 set w $glob(win,bottom).fcmdwin 1754 1755 set botSz [winfo height $w$inst.bot ] 1756 set mainSz [winfo height .] 1757 if {$glob([Opposite $inst],shell,grided)} { 1758 set otherSz [winfo height $w[Opposite $inst]] 1759 } else { 1760 set otherSz 0 1761 } 1762 set pixPerLine [font metric [$w$inst.text cget -font] -line] 1763 frputs inst pixPerLine otherSz mainSz botSz 1764 set maxSz [expr {max(($mainSz - $otherSz - $botSz - 8) / $pixPerLine , 1)}] 1765 if {$rq} { 1766 $w$inst.text config -height [expr {min($config(shell,height,$inst),$maxSz)}] 1767 return 1768 } 1769 # Only mess with this if we are making it smaller... 1770 if {[$w$inst.text cget -height] <= $maxSz} {return} 1771 $w$inst.text config -height $maxSz 1772 set config(shell,height,$inst) [expr {min($config(shell,height,$inst),$maxSz)}] 1773 set glob($inst,shell,maxed) 1 1774 if {$maxSz == 1 && $otherSz > 1} { 1775 MaxCmdText [Opposite $inst] 1776 } 1777} 1778 1779proc CmdWinVis {inst vis} { 1780 global glob 1781 # There is a timing issue here, lets try to smooth things out... 1782 set glob(lastVis) [list $inst $vis] 1783 if {[info exists glob(VisAfter)]} { 1784 after cancel $glob(VisAfter) 1785 } 1786 set glob(VisAfter) [after 500 CmdWinVisComp] 1787 frputs vis 1788} 1789 1790proc CmdWinVisComp {} { 1791 global glob 1792 unset -nocomplain glob(VisAfter) 1793 if {[info exists glob(lastVis)]} { 1794 lassign $glob(lastVis) inst obs 1795 if {$obs != "VisibilityUnobscured"} { 1796 MaxCmdText $inst 1797 } 1798 } 1799} 1800 1801#================================ Build command windows ==================== 1802proc BuildCmdWindow { inst } { 1803 global glob config 1804 1805 set w $glob(win,bottom).fcmdwin$inst 1806 #destroy $w 1807 frame $w -bg green 1808 text $w.text \ 1809 -relief sunken \ 1810 -bd 2 \ 1811 -yscrollcommand "$w.scroll set"\ 1812 -font $glob(gui,ListBoxFont) 1813 # -height $config(shell,height,$inst) 1814 lappend glob(winlist,color_xx) $w.text 1815 #frame $w.fr -bd 0 1816 scrollbar $w.scroll -command "$w.text yview" 1817 frame $w.bot -bd 0 -background yellow 1818 entry $w.bot.entry \ 1819 -relief ridge \ 1820 -font $glob(gui,ListBoxFont) \ 1821 -highlightthickness 1 1822 lappend glob(winlist,color_xx) $w.bot.entry 1823 # lappend glob(winlist,color_cmd) $w.text 1824 label $w.bot.label -textvariable glob($inst,pwdTail) \ 1825 -font $glob(gui,ListBoxFont) \ 1826 -relief ridge \ 1827 -padx 5 1828 button $w.bot.max \ 1829 {*}[getImage -bitmap max @$glob(lib_fr)/bitmaps/max.bit] \ 1830 -command "MaxWin $inst" \ 1831 -bd 1 1832 button $w.bot.smaller \ 1833 {*}[getImage -bitmap smaller @$glob(lib_fr)/bitmaps/smaller.bit] \ 1834 -command " 1835 incr config(shell,height,$inst) -2 1836 if \"\$config(shell,height,$inst)<1\" \" 1837 set config(shell,height,$inst) 1 1838 \" 1839 $w.text configure -height \$config(shell,height,$inst)"\ 1840 -bd 1 1841 button $w.bot.larger \ 1842 {*}[getImage -bitmap larger @$glob(lib_fr)/bitmaps/larger.bit] \ 1843 -command "incr config(shell,height,$inst) 2;\ 1844 MaxCmdText $inst 1" \ 1845 -bd 1 1846 # balloonhelp_for $w.text [_ "Enter commands here, view results above.\ 1847 # \n<Right Mouse button> brings up menu."] 1848 balloonhelp_for $w.bot.max [_ "Toggles this command window between maximum and normal size"] 1849 balloonhelp_for $w.bot.smaller [_ "Makes this command window smaller"] 1850 balloonhelp_for $w.bot.larger [_ "Makes this command window larger"] 1851 label $w.bot.running -text [_ "R"] 1852 1853 #grid rowconfigure $w all -weight 0 1854 grid rowconfigure $w 2 -minsize 20 1855 grid rowconfigure $w 1 -weight 1 1856 1857 grid $w.scroll -row 1 -column [expr {$inst == "left" ? 0 : 2}] -sticky ns 1858 grid $w.text -row 1 -column 1 -sticky news 1859 #grid rowconfig $w $w.text -weight 1 1860 #grid columnconfigure $w 1861 #pack $w.fr -side $inst -fill y 1862 set fixedR [list $w.bot.label $w.bot.entry \ 1863 $w.bot.running $w.bot.smaller $w.bot.larger $w.bot.max] 1864 foreach win $fixedR { 1865 grid $win -row 0 -column [incr col] -sticky ew 1866 grid columnconfig $w.bot $col -weight [expr {$col == 2 ? 1 : 0}] 1867 1868 } 1869 grid $w.bot -row 2 -column 0 -columnspan 4 -sticky ew 1870 # grid rowconfig $w 2 -weight 0 -minsize 22 1871 grid columnconfig $w all -weight 0 1872 grid columnconfig $w 1 -weight 1 1873 1874 #grid rowconfigure $w 1 -weight 1 1875 1876 bind $w.bot <Visibility> [list CmdWinVis $inst %s] 1877 1878 textSearch $w.text [_ "Cmd %s" $inst] "+buildViewConfig CmdConfStrings" {} \ 1879 [list {Save As...} [list ? "SaveToFile $w.text {} 1 " -accelerator C-S]] 1880 # Lower case C-s usually means we have file, but we don't so sent to C-S 1881 bind $w.text <Control-s> "SaveToFile $w.text {} 1 " 1882 bind $w.text <Control-S> "SaveToFile $w.text {} 1 " 1883 # since we don't focus on this window, we need the binds on the one we do 1884 bind $w.bot.entry <Control-s> "SaveToFile $w.text {} 1 " 1885 bind $w.bot.entry <Control-S> "SaveToFile $w.text {} 1 " 1886 set nspace [regsub -all {\.} $w.text {_}]_Sp 1887 bind $w.bot.entry <F3> [list ::${nspace}::SearchView $w.text "+buildViewConfig" 1] 1888 bind $w.bot.entry <Shift-F3> [list ::${nspace}::SearchView $w.text "+buildViewConfig" 2] 1889 bind $w.bot.entry <Control-f> [list ::${nspace}::SearchViewSet $w.text "+buildViewConfig" 0] 1890 1891 bind $w.bot.entry <Return> \ 1892 "ExecCmdInWin $inst $w; catch \"focus $w.bot.entry\" out;break" 1893 bind $w.bot.entry <KP_Enter> \ 1894 "ExecCmdInWin $inst $w;catch \"focus $w.bot.entry\" out; break" 1895 bind $w.bot.entry <Tab> "preComplete $inst $w;break" 1896 bind $w.bot.entry <Control-d> "CompleteDoubleTab $w.bot.entry;break" 1897 bind $w.bot.entry <Control-p> "FlipShellHistory $w.bot.entry $inst searchback 1898 break" 1899 bind $w.bot.entry <Control-c> "DoControlCthing $w $inst;break" 1900 bind $w.bot.entry <Up> "FlipShellHistory $w.bot.entry $inst up;break" 1901 bind $w.bot.entry <Down> "FlipShellHistory $w.bot.entry $inst down;break" 1902 bind $w.bot.entry <Enter> "focus $w.bot.entry" 1903 bind $w.bot.entry <Leave> "focus ." 1904 bind $w.bot.entry <3> "CompleteWithBrowse $w.bot.entry;break" 1905 1906 #bind $w.text <3> "tk_popup $w.text.p %X %Y;break" 1907 bind $w.text <Enter> "focus $w.bot.entry" 1908 bind $w.text <Leave> "focus ." 1909 bind $w.text <FocusIn> "focus $w.bot.entry" 1910 # In windows the MouseWheel events are delivered to the window that 1911 # has focus. Since (because of the above <Enter> sequence) the text 1912 # window MouseWheel events will be delivered to the entry window. 1913 # Thus the following actually works (Magic enough for you?). 1914 bind $w.bot.entry <MouseWheel> "$w.text yview scroll \ 1915 \[expr %D > 0 ? -\$config(mwheel,delta) : \ 1916 $config(mwheel,delta)] units;break" 1917 # In linux, it would appear that the following are not needed, however, 1918 # if we want to control the scroll distance, well... 1919 bind $w.text $config(mwheel,neg) \ 1920 "$w.text yview scroll \ 1921 -\$config(mwheel,delta) units;break" 1922 bind $w.text \ 1923 $config(mwheel,pos) \ 1924 "$w.text yview scroll \ 1925 \$config(mwheel,delta) units;break" 1926 bind $w.bot.entry $config(mwheel,neg) \ 1927 "$w.text yview scroll \ 1928 -\$config(mwheel,delta) units;break" 1929 bind $w.bot.entry \ 1930 $config(mwheel,pos) \ 1931 "$w.text yview scroll \ 1932 \$config(mwheel,delta) units;break" 1933 balloonhelp_for $w.bot.entry \ 1934 {[_b "Command entry window. Bindings: 1935<Return> execute the entered command. 1936<Tab> \tAttempt command completion second 1937 \t<Tab> or <Cntl d> lists possible 1938 \tcompletions in above window. 1939<3> \tcomplete with browser. 1940<Cntl c>\tIf empty entry line abort the 1941 \tlast command else clear the entry line. 1942<Up> \tMove back in shell history. 1943<Down> \tMove forward in shell history. 1944<Cntl p>\tSearch back in command stack for 1945 \tcommand using entry as a pattern." ]} 1946} 1947#====================================== End of command window build ================== 1948 1949 1950# Here we close the channel that is controlling the shell 1951# We always close the first entry and the command puts 1952# new entries last, thus we always do the oldest first. 1953# the command code needs to remove entries in random order depending 1954# of the order of compeltion. 1955# We assume serial running, i.e. the command will not interrupt us 1956# with its completion, thus no locks are needed. 1957 1958proc DoControlCthing { w inst } { 1959 global glob 1960 if { [$w.bot.entry get] != "" } { 1961 $w.bot.entry delete 0 end 1962 } else { 1963 if { [info exists glob($inst,fid)] && [llength $glob($inst,fid)]} { 1964 set fi [lrange $glob($inst,fid) 0 0] 1965 Log [_ "^C on %s" $glob($inst,fid)] 1966 pipeoAbort $fi 1967 } else { 1968 Log [_ "Command does not exist"] 1969 } 1970 } 1971} 1972 1973 1974proc buildViewConfig {{which {}}} { 1975 global config glob 1976 set vl {} 1977 if {$which !={}} { 1978 set vl [list values ::config(search,$which)\ 1979 valueCount $config(search,limit)] 1980 } 1981 return [list -flashcolor $glob(gui,color_flash)\ 1982 -foreground $glob(gui,color_select_fg)\ 1983 -background $glob(gui,color_select_bg)\ 1984 -state disabled\ 1985 position cent\ 1986 {*}$vl 1987 ] 1988} 1989proc buildDialogConfig {} { 1990 global config glob 1991 set maxw [expr {70 * [font measure $glob(gui,ListBoxFont) {0}]}] 1992 return [list -font $glob(gui,ListBoxFont) \ 1993 -foreground $glob(gui,color_select_fg)\ 1994 -background $glob(gui,color_select_bg)\ 1995 -width 70 \ 1996 -state disabled\ 1997 position cent\ 1998 maxw $maxw] 1999} 2000 2001proc preComplete {inst w} { 2002 global glob config 2003 if { [catch {cd $glob($inst,pwd)} out]} { 2004 PopError "$out" 2005 return "" 2006 } 2007 Complete $w.bot.entry $w.text $config(shell,aliases) \ 2008 $glob(localCmds) type 2009} 2010 2011proc CmdType {w inst args} { 2012 global env config glob 2013 foreach ag $args { 2014 foreach arg $ag { 2015 set indx [lsearch -exact -index 0 $config(shell,aliases) $arg] 2016 if {$indx != -1} { 2017 ToShellBuffer $w "[_ {%s is aliased to} $arg] \ 2018 `[lrange [lindex $config(shell,aliases) $indx] 1 end]'\n" 2019 continue 2020 } 2021 set indx [lsearch -exact $glob(localCmds) $arg] 2022 if {$indx != -1} { 2023 ToShellBuffer $w [_ "%s is a filerunner builtin\n" $arg] 2024 continue 2025 } 2026 if {$::MSW} { 2027 ToShellBuffer $w [windowsAutoExecOk $arg] 2028 } else { 2029 set cmd [list {*}$config(cmd,sh) "type $arg"] 2030 2031 lassign [pipeoExec "$cmd 2>@1" r \ 2032 [list "backTalk $inst $w"]] r fid 2033 2034 #set r [catch {open "|$config(cmd,sh) \{$cmd 2>&1\}" r} fid] 2035 if {$r} { 2036 ToShellBuffer $w [_ "Exec error: %s\n" $fid] 2037 } else { 2038 # fconfigure $fid -buffering none 2039 # fconfigure $fid -blocking 0 2040 # fconfigure $fid -translation auto 2041 # lappend glob($inst,fid) $fid 2042 # # schedule the completer... 2043 # chan event $fid readable "CompleteShell_pipe $inst $w $fid" 2044 incr glob($inst,shellcount) 2045 set glob($inst,runlabel,bg) [$w.bot.running cget -bg] 2046 $w.bot.running configure -bg red 2047 lappend glob($inst,fid) $fid 2048 vwait glob($inst,shellcount) 2049 } 2050 } 2051 } 2052 } 2053} 2054 2055 2056proc ExecCmdInWin { inst w } { 2057 global glob config env errorInfo 2058 # focus $w.bot.entry 2059 destroy $w.bot.complete 2060 set glob($inst,shell,history,flipping) 0 2061 set glob($inst,shell,complete,flipping) 0 2062 set cmd [string trim [$w.bot.entry get]] 2063 if {$cmd == ""} return 2064 $w.bot.entry delete 0 end 2065 $w.text mark set insert end 2066 $w.text see insert 2067 if {[set idx [lsearch -exact $glob($inst,shell,history) $cmd]] != -1} { 2068 set glob($inst,shell,history) [lreplace $glob($inst,shell,history) $idx $idx] 2069 } 2070 lappend glob($inst,shell,history) $cmd 2071 2072# if {[IsVFS $glob($inst,pwd)] && ![string match "%*" $verb ]} { 2073# PopError [_ "Sorry, can't execute commands in ftp directories"] 2074# return 2075# } 2076 if { [IsVFS $glob($inst,pwd)] } { 2077 set r [catch {VFScd $glob($inst,pwd)} out] 2078 } else { 2079 set r [catch {cd $glob($inst,pwd)} out] 2080 } 2081 if {$r } { 2082 PopError "$out" 2083 return 2084 } 2085 # use double quotes to round up the spaces... 2086 # We have to be VERY careful not to use list structure things here 2087 # as they introduce {}'s and miss handle []' 2088 # we want to convert 'x\ y' to '"x y"' 2089 # AND we want to convert other '\' so that they stay around... 2090 # Mostly for Windows 2091 2092 set cmd [bslashSpcToQuot $cmd] 2093 set r [catch {set verb [lindex $cmd 0]} out] 2094 if {$r } { 2095 ToShellBuffer $w "\n$glob($inst,pwdTail) > $cmd\n" 1 2096 eval {ToShellBuffer $w [_ "tcl error: %s" $out]} 2097 if {$glob(debug)} { 2098 ToShellBuffer $w $::errorInfo 2099 } 2100 return 2101 } 2102 # expand aliases 2103 set alias "" 2104 foreach k $config(shell,aliases) { 2105 if {$verb == [lindex $k 0]} { 2106 set alias [lindex $k 1] 2107 break 2108 } 2109 } 2110 if {$alias != ""} { 2111 # This way of replacing 'verb' does not mess with the quoted 2112 # spaces. 2113 set cmd [regsub $verb $cmd $alias] 2114 set verb [lindex $cmd 0] 2115 } 2116 # echo command to the window 2117 ToShellBuffer $w "\n$glob($inst,pwdTail) > $cmd\n" 1 2118 update 2119 set len [llength $glob($inst,shell,history)] 2120 if {$len > 250} { 2121 set glob($inst,shell,history) \ 2122 [lrange $glob($inst,shell,history) [expr $len - 200] end] 2123 } 2124 set prefix " " 2125 Log [_ "switch on %s" $verb] 2126 switch -glob $verb { 2127 %* { 2128 # Tcl commands 2129 set prefix "Tcl: " 2130 set r [catch { 2131 uplevel #0 [string range [regsub {\\} $cmd {\\\\}] 1 end] } out] 2132 if {$r} { 2133 ToShellBuffer $w [_ "tcl error: %s" $out] 2134 if {$glob(debug)} { 2135 ToShellBuffer $w "$errorInfo" 2136 } 2137 } else { 2138 ToShellBuffer $w "$out" 2139 } 2140 } 2141 cd { 2142 # this code is a little extra fluffy, because we want 2143 # to avoid the error handling in NewPwd/UpdateWindow 2144 # which we could have used also, but it doesn't look 2145 # as neat. (It pops up an error popup...) 2146 Log "cd" 2147 set newpwd [lindex $cmd 1] 2148 if {[IsVFS $glob($inst,pwd)]} { 2149 ToShellBuffer $w [_ "cd not supported as a\ 2150 shell command in VFS directories"] 2151 # NewPwd $inst $newpwd 2152 # UpdateWindow $inst 2153 # ToShellBuffer $w [_ "ok"] 2154 } else { 2155 if {$newpwd == ""} {set newpwd $env(HOME)} 2156 set r [catch {cd $newpwd} out] 2157 if {!$r} { 2158 set r [catch {cd $glob($inst,pwd)} out] 2159 NewPwd $inst $newpwd 2160 UpdateWindow $inst 2161 ToShellBuffer $w [_ "ok"] 2162 } else { 2163 ToShellBuffer $w [_ "cd error: %s" $out] 2164 } 2165 } 2166 } 2167 view { 2168 Log $cmd 2169 if {[IsVFS $glob($inst,pwd)]} { 2170 ToShellBuffer $w [_ "view not supported as \ 2171 shell command in VFS directories"] 2172 } else { 2173 ViewAny [lrange $cmd 1 end] 2174 } 2175 } 2176 history { 2177 Log [_ "history"] 2178 ToShellBuffer $w [join $glob($inst,shell,history) \n] 2179 } 2180 type { 2181 Log $cmd 2182 CmdType $w $inst [lrange $cmd 1 end] 2183 } 2184 2185 default { 2186 Log [_ "\"%s\" default" $cmd] 2187 # check for special commands... 2188 # a background command? 2189 # Note: this sneaks through to the local system even if VFS 2190 if {[string match *& $cmd]} { 2191 set prefix [_ "Background shell: "] 2192 catch {puts "$cmd"} 2193 set cmd [regsub {\\} $cmd {\\\\}] 2194 set cmd [string replace $cmd end end] 2195 if {$::MSW && $config(cmd,sh) == {}} { 2196 set pre [lindex $cmd 0] 2197 set cmd [string trim [regsub $pre $cmd {}]] 2198 2199 set r [catch [list fixMSWcommand "exec $pre &" $cmd -b 1] out] 2200 } else { 2201 catch {eval exec "$cmd &"} out 2202 } 2203 if {$out != 0} { 2204 ToShellBuffer $w $out 2205 } 2206 } elseif {[IsVFS $glob($inst,pwd)] } { 2207 set prefix [_ "VFS command: "] 2208 ToShellBuffer $w [VFScommand $VFStok $cmd] 2209 } else { 2210 # not "&" and not VFS 2211 set prefix [_ "Shell: "] 2212 if {$glob(os) == "Unix"} { 2213 set cmd [regsub -all {\\} $cmd {\\\\}] 2214 } 2215 if {$::MSW} { 2216 if {$config(cmd,sh) == {}} { 2217 # puts "Send this $cmd" 2218 set pre [lindex $cmd 0] 2219 set cmd [string trim [regsub $pre $cmd {}]] 2220 frputs pre cmd 2221 set r [catch [list fixMSWcommand $pre $cmd -fonly 1] cmd] 2222 # puts "This command $cmd" 2223 if {$r != 0} { 2224 ToShellBuffer $w $cmd 2225 return 2226 } 2227 } else { 2228 set cmd [fixMSWcommand "$config(cmd,sh)" $cmd -fonly 1] 2229 #set cmd [regsub -all {\\} $cmd {\\}] 2230 } 2231 } else { 2232 # not windows... 2233 set cmd [list {*}$config(cmd,sh) $cmd] 2234 } 2235 lassign [pipeoExec "$cmd 2>@1" r \ 2236 [list "backTalk $inst $w"]] r fid 2237 if {$r} { 2238 ToShellBuffer $w [_ "Exec error: %s\n" $fid] 2239 } else { 2240 incr glob($inst,shellcount) 2241 if {$glob($inst,shellcount) == 1} { 2242 set glob($inst,runlabel,bg) [$w.bot.running cget -bg] 2243 $w.bot.running configure -bg red 2244 } 2245 lappend glob($inst,fid) $fid 2246 } 2247 } 2248 } 2249 } 2250 Log $prefix$cmd 2251} 2252 2253proc backTalk {inst w fid why {mess {}}} { 2254 global glob 2255 switch -glob $why { 2256 a* - 2257 en* - 2258 k* - 2259 do* { 2260 Log "Shell pipe: $why $mess" 2261 } 2262 da* { 2263 ToShellBuffer $w $mess 2264 } 2265 eo* { 2266 set id [lsearch -exact $glob($inst,fid) $fid] 2267 if { $id >= 0 } { 2268 set glob($inst,fid) [lreplace $glob($inst,fid) $id $id] 2269 } 2270 incr glob($inst,shellcount) -1 2271 if {$glob($inst,shellcount) == 0} { 2272 $w.bot.running configure -bg $glob($inst,runlabel,bg) 2273 } 2274 } 2275 } 2276} 2277 2278 2279proc ToShellBuffer { w chars {cmd 0}} { 2280 global config 2281 $w.text insert end $chars 2282 if { $cmd } { 2283 $w.text tag add command "insert - 1 lines" "insert - 1 chars" 2284 } 2285 $w.text see "insert - 1 chars" 2286 set size_text [file rootname [$w.text index end]] 2287 if {$size_text > [expr ($config(shell,buffer) * 4) / 3]} { 2288 $w.text delete 0.1 [expr ${size_text} - $config(shell,buffer)].1 2289 } 2290} 2291 2292proc ReadDelay { i } { 2293 #puts -nonewline "@" 2294 flush stdout 2295 set len [expr 200 + ($i * 50)] 2296 if {$len > 1000} {set len 1000} 2297 return $len 2298} 2299 2300 2301proc FlipShellHistory { w inst direction } { 2302 global glob 2303 frputs "flip " direction 2304 switch $direction { 2305 up { 2306 if {!$glob($inst,shell,history,flipping)} { 2307 set glob($inst,shell,history,flipping,index) \ 2308 [expr [llength $glob($inst,shell,history)] - 1] 2309 set glob($inst,shell,history,flipping) 1 2310 } else { 2311 incr glob($inst,shell,history,flipping,index) -1 2312 if {$glob($inst,shell,history,flipping,index) < -1} { 2313 set glob($inst,shell,history,flipping,index) -1 2314 } 2315 } 2316 } 2317 down { 2318 if {!$glob($inst,shell,history,flipping)} { 2319 set glob($inst,shell,history,flipping,index) 0 2320 set glob($inst,shell,history,flipping) 1 2321 } else { 2322 incr glob($inst,shell,history,flipping,index) 1 2323 set len [llength $glob($inst,shell,history)] 2324 if {$glob($inst,shell,history,flipping,index) > $len} { 2325 set glob($inst,shell,history,flipping,index) [expr $len] 2326 } 2327 } 2328 } 2329 searchback { 2330 set cmd [string trim [$w get]] 2331 if {$glob($inst,shell,history,flipping) && \ 2332 [string first $glob($inst,shell,history,flipping,cmd) $cmd] == 0} { 2333 # been here before with same command 2334 set cmd $glob($inst,shell,history,flipping,cmd) 2335 set start [expr $glob($inst,shell,history,flipping,index) -1] 2336 if {$start < -1} {set start -1} 2337 #set cmd $glob($inst,shell,history,flipping,cmd) 2338 } else { 2339 # first time here, save current cmd line 2340 set start [expr [llength $glob($inst,shell,history)] - 1] 2341 set glob($inst,shell,history,flipping,cmd) $cmd 2342 } 2343# puts "$cmd $start" 2344 for {set i $start} {$i >= 0} {incr i -1} { 2345 if {[string first $cmd [lindex $glob($inst,shell,history) $i]] == 0} { 2346 set glob($inst,shell,history,flipping,index) $i 2347 set glob($inst,shell,history,flipping) 1 2348 break 2349 } 2350 } 2351 if {!$glob($inst,shell,history,flipping)} return 2352 } 2353 } 2354 $w delete 0 end 2355 $w insert end [lindex $glob($inst,shell,history) \ 2356 $glob($inst,shell,history,flipping,index)] 2357} 2358# ========================= End of the Command window code ================ 2359 2360 2361proc CheckGrab { r reason } { 2362 if {$r} { 2363 LogStatusOnly [_ "%s (non fatal)" $reason] 2364 } 2365} 2366 2367# This routine is for commands that don't want the autoupdater to run 2368# and invoke "update" during operation 2369proc DoProtCmd { cmd } { 2370 DoProtCmd_ $cmd 2371} 2372proc DoProtCmd_NoGrab { cmd } { 2373 DoProtCmd_ $cmd 1 2374} 2375 2376proc DoProtCmd_ {cmd {nograb 0}} { 2377 global glob DoProtLevel 2378 if {! $nograb} { 2379 focus $glob(win,top).status 2380 frgrab $glob(win,top).menu_frame.fasync_cmds 2381 } 2382 set glob(doprot,$DoProtLevel) \ 2383 [list [. cget -cursor] $glob(enableautoupdate)] 2384 incr DoProtLevel 2385 lappend ::DoProtProc $cmd 2386 set ::MaxDoProtLevel [expr {max($DoProtLevel,$::MaxDoProtLevel)}] 2387 # if { ! [info exists glob(oldcur)] || [. cget -cursor] != $glob(oldcur)} { 2388 # set glob(oldcur) [. cget -cursor] 2389 # } 2390# puts "saved $glob(oldcur) $cmd" 2391 # set glob(oldautoup) $glob(enableautoupdate) 2392 . config -cursor circle 2393 #wm iconname . "FileRunner v$glob(displayVersion) - busy" 2394 update idletasks 2395 if {$glob(enableautoupdate) != 0} { 2396 # we do this to avoid extra trace calls (see list updater) 2397 set glob(enableautoupdate) 0 2398 } 2399 # frputs "DoProtCmd: " cmd 2400 uplevel 2 $cmd 2401 UnDoProtCmd 2402} 2403 2404# This is used by the continue button after an error... 2405proc UnDoProtCmd { } { 2406 global glob config DoProtLevel 2407 if {!$DoProtLevel} {return} 2408 incr DoProtLevel -1 2409 set ::DoProtProc [lrange $::DoProtProc 0 end-1] 2410 lassign $glob(doprot,$DoProtLevel) curser update 2411 if {$update != $glob(enableautoupdate) } { 2412 set glob(enableautoupdate) $update 2413 } 2414 set glob(async) 0 2415 . config -cursor $curser 2416# puts "set $glob(oldcur)" 2417 catch {grab release [grab current $glob(win,top).menu_frame.fasync_cmds]} 2418 #catch {focus $glob(focus_before_doprotcmd)} 2419 unset -nocomplain glob(whichdir) 2420 # Not sure if the following line is needed. Be not having it we can 2421 # do much more with Left & Right Up & Down keys even in normal mode. 2422 if {$config(focusFollowsMouse) != 1} { 2423 focus $glob(win,top).status 2424 } 2425 set glob(mbutton) 0 2426} 2427# 2428# This is for the simple case where we just want to protect things like 2429# entry_dialog. We just turn off the updateing and in addition allow 2430# a return value. We do NOT mess with grab and focus... 2431# 2432proc simpDoProt {cmd} { 2433 global glob DoProtLevel 2434 set glob(doprot,$DoProtLevel) [list [. cget -cursor] $glob(enableautoupdate)] 2435 incr DoProtLevel 2436 lappend ::DoProtProc "$cmd -S" 2437 if {$glob(enableautoupdate) != 0} { 2438 # we do this to avoid extra trace calls (see list updater) 2439 set glob(enableautoupdate) 0 2440 } 2441 set rt [uplevel $cmd] 2442 lassign $glob(doprot,[incr DoProtLevel -1]) cursor update 2443 set ::DoProtProc [lrange $::DoProtProc 0 end-1] 2444 if {$update != $glob(enableautoupdate) } { 2445 set glob(enableautoupdate) $update 2446 } 2447 . config -cursor $curser 2448 return $rt 2449} 2450 2451proc SetStartDir { inst } { 2452 global glob config 2453 set config(startpwd,$inst) $glob($inst,pwd) 2454 LogStatusOnly [_ "% set. Do\ 2455 \"Configuration->Save configuration\" if\ 2456 you want to store it to the .fr file" sconfig(startpwd,$inst)] 2457 #SaveConfig 2458} 2459 2460proc SetWinPos {} { 2461 global glob config 2462 if {[wm grid .] == {}} { 2463 set config(geometry,main) [wm geo .] 2464 } else { 2465 set config(geometry,main) [getGeo g[wm geometry .] . -out p] 2466 } 2467 LogStatusOnly \ 2468 [_ "%s set. Do\ 2469 \"Configuration->Save configuration\" if\ 2470 you want to store it to the .fr file" config(geometry,main)] 2471} 2472 2473proc ConstructFileList { inst } { 2474 global glob config 2475 set dirlist $glob($inst,filelist) 2476 set dir $glob($inst,pwd) 2477 2478 foreach flist $glob(listboxNames) { 2479 set glob($inst,lv$flist) {} 2480 } 2481 foreach k $dirlist { 2482# puts "$k" 2483 # asseble the bits the scripts will need. 2484 #lassign $k sortval file type size mtime mode usergroup link nlink atime ctime 2485 lassign $k {*}$glob(fListEl) 2486 #frputs file type 2487 set ffile $file[switch -glob -- $type { 2488 *ld {expr {"@/"}} 2489 *d {expr {[string index $file end] == "/" ? "" : "/"}} 2490 *l {expr {"@"}} 2491 *n {expr {""}} 2492 }] 2493 if {$size == {}} { 2494 set ffile "${ffile}??" 2495 } 2496 foreach lbentry $config(ListBoxColumns,$inst) { 2497 set flist [lindex $lbentry 0] 2498 lappend glob($inst,lv$flist) [eval $glob(lbscript,$flist)] 2499 } 2500 } 2501} 2502 2503proc InitWindows {} { 2504 global glob 2505 set glob(select_cur_lr) {} 2506 set glob(select_pry_s) {} 2507 set glob(select_cur_s) {} 2508 highlightOff 2509 #UpdateWindow both 2510} 2511 2512proc Back { inst } { 2513 global glob 2514 while {[llength $glob($inst,dirstack)] > 0 } { 2515 set dir [lindex $glob($inst,dirstack) 0 0] 2516 if {$dir == $glob($inst,pwd)} { 2517 # if {[llength $glob($inst,dirstack)] == 1} break 2518 set glob($inst,dirstack) [lrange $glob($inst,dirstack) 1 end] 2519 frputs dir glob($inst,dirstack) 2520 continue 2521 } 2522 frputs dir glob($inst,dirstack) 2523 NewPwd $inst $dir 2524 UpdateWindow $inst 2525 set glob($inst,dirstack) [lrange $glob($inst,dirstack) 2 end] 2526 frputs dir glob($inst,dirstack) 2527 break 2528 } 2529 #puts "back: $glob(left,dirstack)\n$glob(right,dirstack)\n" 2530} 2531 2532proc ForceUpdate {{inst both}} { 2533 global glob 2534 set glob(forceupdate) 1 2535 UpdateWindow $inst 2536 set glob(forceupdate) 0 2537} 2538 2539proc ButtonAdd {w inst args} { 2540 global glob config 2541 # each element is args generates a menu entry 2542 # If the first char is '+' the command is added to the 2543 # buttoncmds list. 2544 # if an entry is empty a seperator is generated 2545 # if an entry contains -o (part of -on or -off) a check button is generated 2546 # if neither of the above a command button is generated. 2547 # if an entry contains $inst, it is replaced with the inst parm value 2548 foreach arg $args { 2549 foreach ent $arg { 2550 set butCmd 0 2551 if {[string index $ent 0] == "+"} { 2552 set ent [string range $ent 1 end] 2553 incr butCmd 2554 } 2555 array unset tmp 2556 array set tmp $ent 2557 set tmp(-label) [subst $tmp(-label)] 2558 set tmp(-command) [regsub {P } $tmp(-command) {DoProtCmd }] 2559 set tmp(-command) [regsub {\$inst} $tmp(-command) "$inst"] 2560 set ent [array get tmp] 2561 set type [expr {[string match {* -o*} $ent] ? "check" : 2562 [string match {* -value*} $ent] ? "radio" : "command"}] 2563 $w add $type {*}$ent 2564 if {$butCmd && [list $tmp(-label) $tmp(-command)] ni $glob(buttoncmds)} { 2565 lappend glob(buttoncmds) [list $tmp(-label) $tmp(-command)] 2566 } 2567 } 2568 } 2569} 2570 2571proc BuildFileListPanel { inst } { 2572 2573 global glob config 2574 2575 frame $glob(win,$inst) -borderwidth 1 -relief raised 2576 set wf [frame $glob(win,$inst).dirmenu_frame -borderwidth 1 -relief raised] 2577 set wft [frame $glob(win,$inst).top -bd 1 -relief raised] 2578 # frame $wft.t -bd 0 -relief raised 2579 2580 # The tree button (code is in frUnixBits as MSW version of tk does not 2581 # support the required cascade. 2582 buildTree $wf $inst 2583 2584 # Hotlist button 2585 menubutton $wf.hotlist_but -takefocus 0 -menu \ 2586 $wf.hotlist_but.m -text [_ "Hotlist"] 2587 bind $wf.hotlist_but <Motion> {+ 2588 if {$::tk::Priv(postedMb) == "%W"} { 2589 set ::tk::Priv(menuActivated) 1 2590 } 2591 } 2592 2593 # by specifying tk_popup here we get the desired cascade action 2594 #bind $wf.hotlist_but <1> "::tk_popup $wf.hotlist_but.m %X %Y; break" 2595 2596 menu $wf.hotlist_but.m -font $glob(gui,GuiFont)\ 2597 -tearoff false -postcommand "CreateHotListMenu $inst" 2598 # History button 2599 menubutton $wf.history_but -menu \ 2600 $wf.history_but.m -text [_ "History"] 2601 2602 menu $wf.history_but.m -font $glob(gui,GuiFont)\ 2603 -tearoff false -postcommand "CreateHistoryMenu $inst" 2604 2605 # Etc button 2606 menubutton $wf.etc_but -takefocus 0 -menu \ 2607 $wf.etc_but.m -text [_ "Etc"] 2608 # Build the Etc menu 2609 menu $wf.etc_but.m -tearoff false \ 2610 -font $glob(gui,GuiFont) -postcommand "CreateEtcMenu $wf.etc_but.m $inst" 2611 2612 # Create buttons 2613 # the ^ button 2614 buttonWbitmap $wf.button_parentdir \ 2615 -relief raised \ 2616 -borderwidth 1\ 2617 {*}[getImage -bitmap up @$glob(lib_fr)/bitmaps/up.bit] \ 2618 -command "UpDirTree $inst %X %Y" 2619 2620 # the <- button 2621 button $wft.button_back -takefocus 0 -borderwidth 1 \ 2622 {*}[getImage -bitmap left @$glob(lib_fr)/bitmaps/left.bit] \ 2623 -command "DoProtCmd \" Back ${inst}\"" -width 22 2624 2625 # Start a terminal program button 2626 button $wft.button_xterm -takefocus 0 \ 2627 -borderwidth 1 \ 2628 {*}[getImage -bitmap xterm @$glob(lib_fr)/bitmaps/xterm.bit] \ 2629 -command "StartTerm $inst" 2630 2631 # The command at the bottom button 2632 button $wft.button_frterm -takefocus 0 \ 2633 -borderwidth 1\ 2634 {*}[getImage -bitmap frterm @$glob(lib_fr)/bitmaps/frterm.bit] \ 2635 -command "ToggleCmdWin $inst" 2636 2637 # The update button 2638 button $wft.button_update -takefocus 0 \ 2639 -borderwidth 1\ 2640 {*}[getImage -bitmap update @$glob(lib_fr)/bitmaps/update.bit] \ 2641 -command \ 2642 "DoProtCmd \"set glob(forceupdate) 1; \ 2643 UpdateWindow $inst; set glob(forceupdate) 0\"" 2644 2645 # The dir line window 2646 entry $glob(win,$inst).entry_dir -takefocus 0 \ 2647 -relief {ridge} \ 2648 -font $glob(gui,ListBoxFont) \ 2649 -selectbackground $glob(gui,color_select_bg) \ 2650 -selectforeground $glob(gui,color_select_fg) \ 2651 -background $glob(gui,color_bg) \ 2652 -foreground $glob(gui,color_fg) \ 2653 -highlightthickness 1 2654 lappend glob(winlist,color_xx) $glob(win,$inst).entry_dir 2655 2656 2657 label $wft.stat -text ""\ 2658 -justify center\ 2659 -bd 0\ 2660 -relief raised\ 2661 -font $glob(gui,ListBoxFont) 2662 # The tree entry is first (if unix) and is put here 2663 # by buildTree. 2664 # grid $wf.dir_but -row 1 -sticky ew -column 0 2665 grid $wf.hotlist_but -row 1 -sticky e -column 1 2666 grid $wf.history_but -row 1 -sticky e -column 2 2667 grid $wf.etc_but -row 1 -sticky e -column 3 2668 grid $wf.button_parentdir -row 1 -sticky ew -column 10 2669 2670 grid columnconfigure $wf all -weight 1 2671 grid columnconfigure $wf $wf.button_parentdir \ 2672 -weight 1000 -uniform 0 -minsize 16 2673 2674 grid $wf -row 1 -sticky ew 2675 grid $wft -row 2 -sticky ew 2676 grid $glob(win,$inst).entry_dir -row 3 -sticky ew 2677 # row 4 is the listbox... 2678 grid columnconfigure $glob(win,$inst) all -weight 1 2679 grid rowconfigure $glob(win,$inst) 10 -weight 1 2680 2681 2682 grid $wft.button_back -row 1 -column 0 -sticky ew 2683 grid $wft.button_update -row 1 -column 2 -sticky ew 2684 grid $wft.stat -row 1 -column 3 -sticky ew 2685 grid $wft.button_frterm -row 1 -column 4 -sticky ew 2686 grid $wft.button_xterm -row 1 -column 5 -sticky ew 2687 2688 grid columnconfigure $wft $wft.stat -weight 1 2689 2690# pack $glob(win,$inst).frame_listb -side top -fill both -expand 1 2691# we do the build from the config file read... 2692# buildListBox $inst 2693} 2694 2695proc BuildListBoxes {} { 2696 global glob config 2697 # prevent trying to update while rebuilding 2698 set glob(panelsLocked) 1 2699 ToggleCollock 2700 buildListBox left 2701 buildListBox right 2702 set glob(panelsLocked) \ 2703 [expr {$config(ListBoxColumns,left) != $config(ListBoxColumns,right)}] 2704 ToggleCollock 2705 # ReconfigFont wants to mess with listbox fonts so the listboxes must exist first 2706 ReConfigColors foo 2707 ReConfigFont 2708 2709 foreach men $glob(userMenuList) { 2710 destroy $men 2711 } 2712 set glob(userMenuList) {} 2713 set glob(menus,left) {} 2714 set glob(menus,right) {} 2715 2716 foreach {add ref} [concat [array get config "bind,*"]\ 2717 [array get config "global-bind,*"]] { 2718 switch -glob $ref { 2719 DoMenu,* {} 2720 default { continue } 2721 } 2722 lassign [split $ref ","] junk name 2723 if {![info exists config(menu,$name)]} { 2724 PopError \ 2725 [_ "Config error: config($add) refers to a menu ( config(menu,$name) )\ 2726 \n that does not exist. Binding $add will throw error."] 2727 continue 2728 } 2729 # Build the user menu... 2730 foreach inst {left right} { 2731 if {[lsearch -exact $glob(userMenuList) \ 2732 "$glob(listbox,$inst).file.$name"] == -1} { 2733 lappend glob(menus,$inst) \ 2734 [buildMenu $name $glob(listbox,$inst).file $inst $config(menu,$name)] 2735 } 2736 } 2737 } 2738 # Here we look up the bindings for each of the configured buttons 2739 foreach {but val} [array get config "bind,*"] { 2740 foreach inst {left right} { 2741 set glob($but,$inst) [findCommand $val $inst] 2742 } 2743 } 2744} 2745 2746proc buildMenu {name w inst val} { 2747 global glob config 2748 menu $w.$name \ 2749 -tearoffcommand FixTearoff \ 2750 -title $name \ 2751 -tearoff true \ 2752 -font $glob(gui,GuiFont) 2753 foreach it $val { 2754 lassign $it itm actual 2755 set actual [expr {$actual == {} ? $itm : $actual }] 2756 switch -glob $itm { 2757 {} { $w.$name add separator} 2758 menu,* { 2759 set cname [regsub {[^,]*,(.*)} $itm {\1}] 2760 if {![info exists config(menu,$cname)]} { 2761 PopError "menu $cname refered to by menu $name does not exist. \ 2762 \nSkiping cascade menu." 2763 } else { 2764 if {[string match "*.$cname.*" $w.$name]} { 2765 PopError "menu '$name' makes a recursive reference to menu '$cname'. \ 2766 \nSkiping cascade menu." 2767 } else { 2768 $w.$name add cascade -menu $w.$name.$cname -label $cname 2769 buildMenu $cname $w.$name $inst $config(menu,$cname) 2770 } 2771 } 2772 } 2773 default { 2774 set cmd "[findCommand [lindex $actual 0] $inst] [lrange $actual 1 end]" 2775 $w.$name add command -label $itm \ 2776 -command "DoMenu [list $cmd $inst] " 2777 foreach entry $config(middle_button_colors) { 2778 lassign $entry thename color 2779 if {$thename == $actual} { 2780 switch -glob $color { 2781 -* {$w.$name entryconfigure end -activebackground \ 2782 [string range $color 1 end]} 2783 default {$w.$name entryconfigure end -background $color} 2784 } 2785 } 2786 } 2787 } 2788 } 2789 } 2790 lappend glob(userMenuList) "$w.$name" 2791 return [list DoMenu,$name "RaiseMenu $w.$name"] 2792} 2793 2794proc findCommand {name inst} { 2795 global glob 2796 foreach ent [concat $glob(buttoncmds) \ 2797 $glob(middlebuttoncmds) \ 2798 $glob(menus,$inst)] { 2799 lassign $ent nam cmd 2800 if {$nam == $name} {return $cmd} 2801 } 2802 #error "command $name not found" 2803 return $name 2804} 2805# 2806# Give 'this' a string containing either 'left' or 'right' return the 2807# same string with 'left' replaced by 'right' and 'right' replaced by 'left' 2808# 2809proc OpName {this} { 2810 return [string map {left right right left} $this] 2811} 2812 # Create listbox ========================================================== 2813proc buildListBox {inst} { 2814 global glob config 2815 destroy $glob(win,$inst).frame_listb 2816 frame $glob(win,$inst).frame_listb -bd 0 2817 2818 2819 set lbw [multilist $glob(win,$inst).frame_listb config(ListBoxColumns,$inst) \ 2820 -toptions [list -relief {ridge} \ 2821 -bd 0]\ 2822 -loptions [list -relief {ridge} \ 2823 -selectmode extended] \ 2824 -boptions [list {*}[getImage -bitmap toggle\ 2825 @$glob(lib_fr)/bitmaps/toggle.bit] \ 2826 -command "ToggleSelect $inst" \ 2827 -bd 1 -height 12]\ 2828 -font $glob(gui,ListBoxFont) \ 2829 -selectscript "ListBoxSelected" \ 2830 -listcolumnscroll $config(columnScroll) \ 2831 -soptions "-width $config(columnScrollSize)"\ 2832 ] 2833 set glob(listbox,$inst) $lbw 2834# puts "window name is $lbw" 2835 foreach lbentry $config(ListBoxColumns,$inst) { 2836 set swinn [lindex $lbentry 0] 2837 $lbw.$swinn config -listvariable glob($inst,lv$swinn) 2838 } 2839 set newcolorlist {} 2840 foreach entry $glob(winlist,color_xx) { 2841 if {[string match "$lbw.*" $entry] } continue 2842 lappend newcolorlist $entry 2843 } 2844 set glob(winlist,color_xx) $newcolorlist 2845 2846 # set newtablist {} 2847 # foreach entry $glob(gui,tablist) { 2848 # if {[string match "$lbw.*" $entry] } continue 2849 # lappend newtablist $entry 2850 # } 2851 foreach winn $config(ListBoxColumns,$inst) { 2852 set swin [lindex $winn 0] 2853 set wd $lbw.$swin 2854 lappend glob(winlist,color_xx) $wd $lbw.label$swin 2855 balloonhelp_for $lbw.label$swin {[_b "List box entry labels." ]} 2856 2857 balloonhelp_for $wd \ 2858 {[_b "Dir list box. Button bindings:\n<Tab>\ 2859 \t\tMove focus to other window 2860 \n<Shift Left Mouse>\ 2861 Extend selection from last single selected entry\n<Cntl Left Mouse>\ 2862 \tAdd the file under the mouse to the selection\n<drag Left Mouse>\ 2863 Add files moved over to the selection\n<char>\ 2864 \t\tScroll window to make files that start with\n\ 2865 \t\t<char> visable. If control <char> or 'Position to\n\ 2866 \t\tdirectories' scroll to make directory entry visable\ 2867 \n\n Mouse buttons 1, 2, & 3 combinations are\n\ 2868 \tConfigurable see 'Mouse Bindings & menus'\n\ 2869 " ]} 2870 # Bind the buttons 2871 bind $wd <Tab> "focus [OpName $wd];break" 2872 bind $wd $config(mwheel,neg) "$wd yview scroll -\$config(mwheel,delta) units 2873 break" 2874 bind $wd config(mwheel,pos) "$wd yview scroll \$config(mwheel,delta)units 2875 break" 2876 bind $wd <2> "ToggleSelectEntry ${inst} %y;break" 2877 bind $wd <B2-Motion> "ToggleSelectEntryMotion ${inst} %y;break" 2878 foreach {but val} [array get config "bind,*"] { 2879 set button [regsub {bind,(.*)} $but {\1}] 2880 if {$val == {}} {continue} 2881 2882 catch {bind $wd <$button> {} } 2883 if {[catch { 2884 bind $wd <$button> "DoBut $button ${inst} \[$wd nearest %y\] %X %Y 2885 break"} out] != 0 } { 2886 if {$inst == "left" } { 2887 # only complain about this on one of the panes 2888 lappend err [list $button $out] 2889 } 2890 } 2891 2892 } 2893 2894 #bind $wd <ButtonRelease-1> "+UpdateStat" 2895 #bind $wd <ButtonRelease-2> "+UpdateStat" 2896 2897 if {$config(keyb_support)} { 2898 #bind $wd <Any-1> "+focus $wd" 2899 bind $wd <Escape> "focus ." 2900 bind $wd <Left> "DoProtCmd \" 2901 NewPwd $inst \\\$glob(${inst},pwd)/.. 2902 UpdateWindow $inst\" 2903 catch \"focus $wd\" 2904 break 2905 " 2906 bind $wd <Right> " 2907 DoProtCmd CmdView 2908 catch \"focus $wd\" 2909 break 2910 " 2911 bind $wd <KeyPress> "DoCommandOnKey $inst %A" 2912 } else { 2913 bind $wd <Escape> break 2914 bind $wd <KeyPress> "ShowListOnKey $inst %A" 2915 } 2916 } 2917 balloonhelp_for $glob(win,$inst).frame_listb.v.but \ 2918 {[_b "Toggle the selection(s)." ]} 2919 # pack $glob(win,$inst).frame_listb -side top -fill both -expand 1 2920 grid $glob(win,$inst).frame_listb -row 10 -sticky news 2921 if {[info exists err]} { 2922 set errlist [lsort -unique $err] 2923 foreach ent $errlist { 2924 lassign $ent button out 2925 # puts "$ent $button $out" 2926 PopError [_ "In trying to bind '%s' in $inst list box \ 2927 \nerror '%s' occured. \ 2928 \n Skipping this binding." $button $out] 2929 } 2930 } 2931} 2932#================ end of mulist listbox set up ======================== 2933 2934# This function seems not to be called and is likely why paste doesn't do 2935# what we would like.... in X, works in Windows... 2936 2937proc GetFileListBoxSTRING_Selection {offset maxBytes } { 2938 global glob 2939 set l {} 2940# puts "building selection responce" 2941 foreach inst {left right} { 2942 foreach sel [$glob(listbox,$inst).file curselection] { 2943 set l "$l $glob($inst,pwd)/[lindex [lindex $glob($inst,filelist) $sel] 1]" 2944 } 2945 } 2946# puts "$l" 2947 return [string range $l 1 $maxBytes] 2948} 2949 2950# called from the ^ button... 2951proc UpDirTree { inst x y} { 2952# Log "$x $y $inst $w" 2953 global glob 2954 set priordir $glob($inst,pwd) 2955 DoProtCmd "NewPwd $inst [list $priordir/..] \; 2956 UpdateWindow $inst" 2957 # The intent here is to put a volume list in the hot list for Windows 2958 # which treats each volume as a totally separate thing... 2959 # Only do this if s/he is trying to go up from the root of the tree... 2960 if {$priordir == $glob($inst,pwd) } { 2961 # We add 10 so the mouse is not in the menu (causes the up event to 2962 # close the menu) 2963 $glob(win,$inst).dirmenu_frame.hotlist_but.m post [expr {$x + 10}] $y 2964 } 2965 return 2966} 2967 2968proc wLinkName {inst fileEnt} { 2969 global glob 2970 lassign $fileEnt {*}$glob(fListEl) 2971 switch -glob $type { 2972 *l* { 2973 return $link 2974 } 2975 } 2976 return {} 2977} 2978 2979proc FTPDateStringToSeconds { date } { 2980 set r [catch {clock scan "$date"} out] 2981 if {!$r} { 2982 # Had to add heuristics here to get the correct year since it 2983 # doesn't say which year in the input string 2984 set today [clock seconds] 2985 # If the date looks like it's more than two months in the future, 2986 # let's subtract a year... 2987 if {$out > ($today+5184000)} { 2988 set t [clock format $out] 2989 set y [lindex $t end] 2990 incr y -1 2991 set t "[lrange $t 0 [expr [llength $t]-3]] $y" 2992 set r [catch {clock scan $t} out2] 2993 if {!$r} { 2994 set out $out2 2995 } 2996 } 2997 return $out 2998 } 2999 set r [catch {clock scan \ 3000 "[lindex $date 1] [lindex $date 0] [lindex $date 2]"} out] 3001 if {$r} {return 0} 3002 return "$out" 3003} 3004 3005proc UpdateWindow { inst } { 3006 global glob 3007 if {$glob(async) == "-a"} return 3008 3009 if {$glob(left,pwd) == $glob(right,pwd)} { 3010 set inst "both" 3011 } 3012 switch $inst { 3013 left { UpdateWindow_ left 0 } 3014 right { UpdateWindow_ right 0 } 3015 both { UpdateWindow_ left 0 3016 if {$glob(left,pwd) == $glob(right,pwd)} { 3017 UpdateWindow_ right 1 3018 } else { 3019 UpdateWindow_ right 0 3020 } 3021 } 3022 } 3023 UpdateStat 3024} 3025 3026# UpdateIf takes zero or more file name(s) and updates if it is 3027# in one of the panel displays 3028proc UpdateIf {args} { 3029 global glob 3030 set done {} 3031 set doneDir {} 3032 frputs args 3033 foreach file $args { 3034 frputs #2 args 3035 set dir [URL norm $file/..] 3036 if {$dir in $doneDir} {continue} 3037 lappend doneDir $dir 3038 if {[IsVFS $dir]} { 3039 ::VFSvars::VFS_InvalidateCache $dir 3040 } 3041 frputs dir 3042 foreach inst {left right} { 3043 if {$inst ni $done && $dir == $glob($inst,pwd)} { 3044 ForceUpdate $inst 3045 lappend done $inst 3046 } 3047 } 3048 } 3049} 3050 3051proc ForceUpdate {{inst both}} { 3052 global glob 3053 set glob(forceupdate) 1 3054 UpdateWindow $inst 3055 set glob(forceupdate) 0 3056} 3057 3058proc UpdateWindow_ { inst quick } { 3059 global glob config 3060 3061 # clear the select history 3062 if {$inst == $glob(select_pry_lr)} { 3063 highlightOff 3064 } 3065 if {$inst == $glob(select_cur_lr)} { 3066 set glob(select_cur_lr) {} 3067 } 3068 3069 # Up date the free bytes on the device... 3070 if {[IsVFS $glob($inst,pwd)]} { 3071 set glob($inst,df) ? 3072 } 3073 3074 # entry_dir is the contents of the dir box at the head of the dir window 3075 # If ftp and not a fourced update and old==new, just update entry_dir 3076 if { [IsVFS $glob(${inst},pwd)] && (!$glob(forceupdate)) } { 3077 if {$glob(${inst},update_oldpwd) == $glob(${inst},pwd)} { 3078 setDisplayDir $inst 3079 return "" 3080 } 3081 } 3082 set Other [Opposite $inst] 3083 # next line for autoupdater 3084 # (quick => left==right this is right and just did left or visa versa) 3085 if {$quick} { 3086 set glob($inst,lastmtime) $glob($Other,lastmtime) 3087 set oldy [lindex [$glob(listbox,$Other).file yview] 0] 3088 } else { 3089 catch {set glob($inst,lastmtime) [file mtime $glob($inst,pwd)]} 3090 set oldy [lindex [$glob(listbox,$inst).file yview] 0] 3091 } 3092 3093 set oldlist $glob(${inst},filelist) 3094 # use other window if it is the same and current... 3095 if {$quick} { 3096 set r 0 3097 set glob(${inst},filelist) $glob($Other,filelist) 3098 set glob($inst,df) $glob($Other,df) 3099 } else { 3100 if {[IsVFS $glob($inst,pwd)] && $glob(forceupdate) } { 3101 ::VFSvars::VFS_InvalidateCache $glob($inst,pwd) 3102 } 3103 while {[set r [catch {GetDirList $inst} glob(${inst},filelist)]] != 0} { 3104 # Failure to read a dir. Lets just go up the tree and try again. 3105 frputs glob(${inst},filelist) 3106 NewPwd $inst $glob($inst,pwd)/.. goUp 3107 } 3108 } 3109 setDisplayDir $inst 3110 3111 # if old list is same as new and not forced... over and out. 3112 if {$oldlist == $glob(${inst},filelist) && (!$glob(forceupdate))} { 3113 set glob(${inst},update_oldpwd) $glob(${inst},pwd) 3114 return 3115 } 3116 # populate the list box 3117 if {$quick} { 3118 foreach flist $glob(listboxNames) { 3119 set glob($inst,lv$flist) $glob($Other,lv$flist) 3120 } 3121 } else { 3122 set start [clock mill] 3123 ConstructFileList $inst 3124 set DisTime [expr {[clock mill] - $start}] 3125 frputs DisTime 3126 } 3127 # Here is where we position the text in the window.... 3128 # Not completly sure why we need the update, but if we don't the 3129 # yview moveto will not work correctly. 3130 update idletasks 3131 if {$glob(${inst},update_oldpwd) == $glob(${inst},pwd)} { 3132# How do we do this now? 3133 $glob(listbox,$inst).file yview moveto $oldy 3134 } else { 3135 # frputs glob($inst,dirstack) 3136 set idx \ 3137 [lsearch -index 0 -exact -start 1 $glob($inst,dirstack) $glob(${inst},pwd)] 3138 if {$idx != -1} { 3139 set index [lindex $glob($inst,dirstack) $idx 1] 3140 $glob(listbox,$inst).file activate $index 3141 $glob(listbox,$inst).file see $index 3142 if {($config(keyb_support) || 1) && \ 3143 [$glob(listbox,$Other).file curselection] == {} } { 3144 $glob(listbox,$inst).file selection set $index 3145 propagateSelection $glob(listbox,$inst).file 3146 } 3147 } 3148 # if {[lindex $glob($inst,dirstack) 1 0] == $glob(${inst},pwd) } { 3149 # } 3150 } 3151 set glob(${inst},update_oldpwd) $glob(${inst},pwd) 3152} 3153 3154################################## DisplayName code ##################### 3155# We want this to be a two way street, dir -> dir with embeded display name 3156# and "display name" -> dir 3157# The first conversion should be fast while we don't want to slouch much 3158# on the the 2ed. 3159# For the first, since we will often get results that start with a DN and 3160# finish with a sub dir AND will have cases where the sub dir may also 3161# have a DN, we will set up a list of doublets {dir DN} and insure that 3162# the longest dirs are befor shorter ones. This also allows us to use 3163# the "string map" code to do the conversion. Using "string map" eliminates 3164# all the partial string work.. 3165# To go the other way (DN to dir) we will just use the array notation. 3166# 3167# So, we mantain two reps, the list of doublets and the array. 3168# To keep every thing straight we do all the list/array stuff here. 3169# 3170# We have 4 routines: 3171# 3172# 1) addDN list {may add more than one, dublets, {dir name}} 3173# dir must be absolute and name unique 3174# error checking to insure absolute path and unique 3175# 1.1) addDNtoList {No error checking, sorts on path length} 3176# 2) delDN name {only one at a time} 3177# 3) dirToDN dir {returns the dir with a DN inserted if needed} 3178# 3.1) dirToDNexact dir {only exact match returned. For building dir list 3179# 4) DNtoDir nam {returns the dir with any DN expanded} 3180# 5) DNtoDirtail nam {returns dir using only the the tail, used by cmds} 3181# set DNlist {} 3182 3183# On CASE, Display names have case, Dirs do not! Nuf said! 3184 3185# On collision, if the dir already has a DN, we want to redefine it. 3186# if the DN is already used, we want to throw an error 3187# In addition, if the dir is not nil or absolute, throw an error. 3188# Mark our errors with "-" as first char. so they can be identified. 3189 3190 3191proc addDN {newDN} { 3192 global DNlist DNtoDir DirToDN 3193 # frputs #2 #1 newDN 3194 foreach {dir name} $newDN { 3195 # To avoid confusion we change the / and \ characters 3196 # to other UTF-8 chars that look the same (well really close) 3197 set name [regsub -all {/} $name $::optionalSlash] 3198 set name [regsub -all {\\} $name $::optionalBackSlash] 3199 set oldName [dirToDNexact $dir] 3200 # if exact, its a dup, just skip 3201 # frputs oldName name 3202 if {$oldName == $name} {continue} 3203 # if the difference is only case and MSW, skip other tests 3204 if {[info exists DNtoDir($name)] ||\ 3205 $dir != {} && ![IsVFS $dir] &&\ 3206 (($::MSW && ![regexp -nocase {^([a-z]:|//)} $dir]) ||\ 3207 (!$::MSW && [string index $dir 0] != "/"))} { 3208 set ms [_ "\"%s\" not an absolute path or \"%s\" already exists" $dir $name] 3209 return -code error "- $ms" 3210 } 3211 # Volume names must have trailing / 3212 # if {$::MSW && [string match -nocase {[a-z]:} $dir]} { 3213 # set dir $dir/ 3214 # } 3215 if {$::MSW && [string match -nocase {[a-z]:/} $dir]} { 3216 set dir [string range $dir 0 end-1] 3217 } 3218 if {$oldName != {}} { 3219 delDN $oldName 3220 } 3221 addDNtoList [list $dir $name] 3222 } 3223} 3224 3225# addDNtoList is called to add new entries and also to 3226# resort the list after a delete 3227# We could mess with case issues in the compare but it 3228# makes no real difference as the length is most important. 3229 3230# THIS ROUTINE ASSUMES ERROR CHECKING HAS ALREADY BEEN DONE 3231 3232proc addDNtoList {newDN} { 3233 global DNlist DNtoDir DirToDN 3234 set DNlist [concat $DNlist $newDN] 3235 set nl {} 3236 foreach {dir name} $DNlist { 3237 lappend nl [list $dir $name] 3238 } 3239 # frputs #3 #2 #1 nl 3240 set nl [lsort -command {apply {{a b} { 3241 expr {[set l [expr {[string length $b] -\ 3242 [string length $a]}]] != 0 ? $l :\ 3243 [string compare $b $a]}}}} \ 3244 -index 0 -unique $nl] 3245 set DNlist {} 3246 # frputs nl 3247 foreach nle $nl { 3248 lappend DNlist {*}$nle 3249 } 3250 # frputs nl DNlist 3251 array unset DirToDN 3252 array unset DNtoDir 3253 array set DNtoDir [lreverse $DNlist] 3254 array set DirToDN $DNlist 3255} 3256 3257proc delDN {name} { 3258 global DNlist DNtoDir 3259 # I suppose this could be faster, but we don't expect to do this often 3260 unset -nocomplain DNtoDir($name) 3261 set DNlist {} 3262 # This depends on a full sort as well as the -unique... 3263 addDNtoList [lreverse [array get DNtoDir]] 3264} 3265 3266# This version is exact only 3267# case issues here! 3268proc dirToDNexact {name} { 3269 global DirToDN 3270 if {[info exist DirToDN($name)]} { 3271 return $DirToDN($name) 3272 } else { 3273 return {} 3274 } 3275} 3276 3277# Case issues here 3278proc dirToDN {name} { 3279 global DNlist 3280 # set opt [expr {$::MSW ? "-nocase" : ""}] 3281 set ln [string length $name] 3282 if {$ln == 0} { 3283 if {[lindex $DNlist end-1] == {}} { 3284 return [lindex $DNlist end] 3285 } else { 3286 return $name 3287 } 3288 } 3289 # The DNlist is a sorted dict list with the longest directorys 3290 # first. Thus if both /foo and /foo/bar are in the list we 3291 # will find /foo/bar. So we will do a search in a foreach... 3292 foreach {dir Dname} $DNlist { 3293 if {[set lt [string length $dir]] == 0} { 3294 break 3295 } 3296 # frputs lt dir Dname ln 3297 if {$lt <= $ln && [string equal {*}$::CASEops -length $lt $dir $name]} { 3298 # This is either it or it does not exist in our list 3299 if {[string index $name $lt] in {/ {}}} { 3300 return $Dname[string range $name $lt end] 3301 } 3302 break 3303 } 3304 } 3305 return $name 3306} 3307 3308# In the below, any part of 'name' that is a display name 3309# has case. 3310 3311proc DNtoDir {name} { 3312 global DNtoDir 3313 # again, we could mess arround with a string map, but... 3314 # that would require a new sort as well. 3315 # Here we take advantage of the fact that a DN must be the 3316 # first thing in a dir. We also have //sys to worry about. 3317 set idx [string first "/" $name] 3318 if {[string index $name $idx+1] == "/"} { 3319 set idx [string first "/" $name $idx+2] 3320 } 3321 incr idx -1 3322 if {$idx < 0} { 3323 set idx "end" 3324 } 3325 # frputs idx 3326 set fname [string range $name 0 $idx] 3327 if {[info exists DNtoDir($fname)]} { 3328 return $DNtoDir($fname)[string range $name $idx+1 end] 3329 } else { 3330 return $name 3331 } 3332} 3333# 3334# And this is for when we want to pull a name out of a dir list... 3335# We should have the full path/name and will return that if 3336# there is no DN, otherwise the Dir. 3337# We have a context issue here. If we find an entry for the tail 3338# we need to also insure that the rest of the path matches otherwise 3339# we will treating normal dir names as display names and going off 3340# to never never land... 3341 3342proc DNtoDirTail {name} { 3343 global DNtoDir 3344 set tail [file tail $name] 3345 if {[info exist DNtoDir($tail)]} { 3346 set pos $DNtoDir($tail) 3347 if {[file dirname $name] in [list . [file dirname $pos]]} { 3348 return $pos 3349 } 3350 } 3351 return $name 3352} 3353############################### End of display name code ################ 3354 3355proc setDisplayDir {inst} { 3356 global glob 3357 $glob(win,$inst).entry_dir delete 0 end 3358 $glob(win,$inst).entry_dir insert end [dirToDN $glob(${inst},pwd)] 3359 $glob(win,$inst).entry_dir xview end 3360 $glob(win,$inst).entry_dir xview scroll 1 unit 3361 set glob(whichdir) $inst 3362} 3363 3364proc GotoNewDir { inst { ask 0 } } { 3365 global glob 3366 if { ! $ask } { 3367 set newdir [DNtoDir [$glob(win,$inst).entry_dir get]] 3368 } else { 3369 # this takes us to the volume dir. 3370 set newdir "" 3371 } 3372 DoProtCmd { 3373 NewPwd ${inst} $newdir 3374 UpdateWindow ${inst} 3375 } 3376 focus . 3377} 3378 3379 3380proc SelectThis {inst sel} { 3381 global glob 3382 if {$sel == {}} {return} 3383 foreach select $sel { 3384 $glob(listbox,$inst).file selection set $select 3385 } 3386 propagateSelection $glob(listbox,$inst).file 3387 UpdateStat_ $inst 3388} 3389# Here when a list box selection changes sel is a list of entries currently 3390# selected (may be empty). 3391# 3392proc ListBoxSelected { w sel} { 3393 global glob 3394# puts "listboxselect $w $sel" 3395 if { $sel == "" } return 3396 if {$w != $glob(listbox,left)} { 3397 set inst right 3398 set other $glob(listbox,left) 3399 } else { 3400 set inst left 3401 set other $glob(listbox,right) 3402 } 3403 set glob(selected) $inst 3404 $other.file selection clear 0 end 3405 propagateSelection $other.file 3406 set glob(selectFileList) {} 3407 foreach selent $sel { 3408 lappend glob(selectFileList) \ 3409 $glob($inst,pwd)/[lindex $glob($inst,filelist) $selent 1] 3410 } 3411 # Make the selection available to the window system 3412 $glob(selectWindow) selection set 0 end 3413 # Arange to have the window system tell us when it is lost 3414 selection own -command "TextBoxSelect $w" $glob(selectWindow) 3415 UpdateStat 3416} 3417# We come here when ever we loose the selection. 3418proc TextBoxSelect {w } { 3419# puts "TextBoxSelect $w" 3420 global glob 3421 $w.file selection clear 0 end 3422 propagateSelection $w.file 3423 highlightOff 3424 set glob(select_cur_lr) {} 3425} 3426proc ToggleSelectEntry { inst y } { 3427 global glob 3428# puts "ToggleSelectEntry $inst $y" 3429 set index [$glob(listbox,$inst).file nearest $y] 3430 if {[$glob(listbox,$inst).file selection includes $index]} { 3431 $glob(listbox,$inst).file selection clear $index 3432 set glob(listbox,last) clear 3433 set glob(listbox,last,idx) $index 3434 } else { 3435 $glob(listbox,$inst).file selection set $index 3436 set glob(listbox,last) set 3437 set glob(listbox,last,idx) $index 3438 } 3439 propagateSelection $glob(listbox,$inst).file 3440} 3441 3442proc ToggleSelectEntryMotion { inst y } { 3443 global glob 3444 # For some reason, sometimes the ToggleSelectEntry function 3445 # does not get called before this.... 3446 if {[info exists glob(listbox,last)]} { 3447 set index [$glob(listbox,$inst).file nearest $y] 3448 $glob(listbox,$inst).file selection \ 3449 $glob(listbox,last) $glob(listbox,last,idx) $index 3450 propagateSelection $glob(listbox,$inst).file 3451 } 3452} 3453 3454proc InitBindings {} { 3455 global config glob 3456 3457 foreach inst {left right} { 3458 bind $glob(win,$inst).entry_dir <Key> "set glob(whichdir) $inst" 3459 bind $glob(win,$inst).entry_dir <Return> "GotoNewDir $inst;break" 3460 bind $glob(win,$inst).entry_dir <KP_Enter> "GotoNewDir $inst;break" 3461 bind $glob(win,$inst).entry_dir <3> "GotoNewDir $inst 1;break" 3462 bind $glob(win,$inst).entry_dir <<Paste>> "Do_Paste_dir $inst CLIPBOARD" 3463 bind $glob(win,$inst).entry_dir <<PasteSelection>> "Do_Paste_dir $inst" 3464 bind $glob(win,$inst).entry_dir <Escape> "\ 3465 DoProtCmd \"UpdateWindow ${inst}\" 3466 focus ." 3467 } 3468} 3469 3470#bind $glob(win,$inst).entry_dir <B2-ButtonRelease> "Do_Paste_dir $inst B2" 3471 3472# The get_Pasted command makes every attempt to decode a paste and return 3473# the "expected" result. While "selection" says it is for X11 it seems to work 3474# for MSW as well... We prefer UTF8 and CLIPBOARD 3475 3476proc get_Pasted {{sel PRIMARY}} { 3477 foreach typ {UTF8_STRING STRING} { 3478 if {![catch {selection get -selection $sel -type $typ} select]} { 3479 return $select 3480 } 3481 } 3482 return {} 3483} 3484 3485proc Do_Paste_dir { inst {t PRIMARY}} { 3486 global glob 3487 3488 set dir "[get_Pasted $t]" 3489 # Do a normal paste if not a file (or not one we can look at) 3490 # take care of embeded newlines using only the first one 3491 set dir [lindex [split $dir \n] 0] 3492 if {![IsVFS $dir] && ![file exists $dir]} {return} 3493 frputs dir 3494 if {[catch {LnkFile $dir to xdir} out] == 0 && $out} { 3495 set dir $to 3496 #set filetype [expr {$xdir ? {wld} : {wl}}] 3497 # if {$xdir} { 3498 # GotoFind 3499 # } 3500 } 3501 if {![file exists $dir]} {return} 3502 frputs dir 3503 # if it is a link, get that... 3504 set dir [URL dir [URL norm $dir/x]] 3505 DoProtCmd { 3506 GotoFind [URL dir $dir] [file tail $dir] $inst 3507 } 3508 return -code break 3509} 3510 3511proc DoCommandOnKey { inst key } { 3512 global glob 3513 if {$key == ""} return 3514 if {$key == "\r"} { 3515 DoProtCmd "CmdView" 3516 catch {focus $glob(listbox,$inst).dir} 3517 return 3518 } 3519 foreach k $glob(cmds,list) { 3520 if {$key == [lindex $k 2]} { 3521 DoProtCmd "[lindex $k 1]" 3522 catch {focus $glob(listbox,$inst).dir} 3523 return 3524 } 3525 } 3526 LogStatusOnly [_ "Cannot recognize keyboard shortcut %s" $key] 3527} 3528 3529proc UpdateStat { } { 3530 global glob 3531 if {! ([UpdateStat_ left] | [UpdateStat_ right]) } { 3532 set glob(select_cur_lr) {} 3533 } 3534} 3535 3536proc twidleHighlight { inst onoff items } { 3537 global glob config 3538 if {$onoff == "off" } { 3539 set way "-bg {} -fg {}" 3540 } else { 3541 set way "-bg $glob(gui,color_highlight_bg)\ 3542 -fg $glob(gui,color_highlight_fg)" 3543 } 3544 foreachButListbox $glob(listbox,$inst) \ 3545 "\{ foreach ind \{$items\} { 3546 \$wc.\$win itemconfigure \$ind $way \ 3547 }\}" \ 3548 ".-" 3549} 3550 3551proc highlightOff {} { 3552 global glob 3553 if {[info exists glob(select_pry_lr)] && $glob(select_pry_lr) != {}} { 3554 twidleHighlight $glob(select_pry_lr) off $glob(select_pry_s) 3555 } 3556 set glob(select_pry_lr) {} 3557} 3558 3559proc UpdateStat_ { inst } { 3560 global glob config 3561 set oldena $glob(enableautoupdate) 3562 if {$oldena != 0 } { 3563 set glob(enableautoupdate) 0 3564 } 3565 3566 # We want to keep track of the last selection (which we call pry for prior). 3567 # this is used in the diff command. Want to add highlight...................... 3568 # suffix 'lr' == left right 3569 # suffix 's' == selection 3570 set extending 0 3571 set select [$glob(listbox,$inst).file curselection] 3572 if {$inst == $glob(select_cur_lr) } { 3573 foreach s $select { 3574 # extending the selection..? 3575 if {$s in $glob(select_cur_s)} { 3576 set glob(select_cur_s) $select 3577 # if { $glob(enableautoupdate) != $oldena} { 3578 # set glob(enableautoupdate) $oldena 3579 # } 3580 set extending 1 3581 break 3582 } 3583 } 3584 } 3585 if {[llength $select] && ! $extending} { 3586 # puts "found selection $inst" 3587 if { $inst != $glob(select_cur_lr) || 3588 $select != $glob(select_cur_s)} { 3589 # Remove old highlight it any 3590 if {$glob(select_pry_lr) != {}} { 3591 twidleHighlight $glob(select_pry_lr) off $glob(select_pry_s) 3592 } 3593 3594 if {$glob(select_cur_lr) != {} } { 3595 twidleHighlight $glob(select_cur_lr) on $glob(select_cur_s) 3596 } 3597 3598 set glob(select_pry_lr) $glob(select_cur_lr) 3599 set glob(select_pry_s) $glob(select_cur_s) 3600 set glob(select_cur_lr) $inst 3601 set glob(select_cur_s) $select 3602 # Here we set up and display the first selected file 3603 # and all it bits ... 3604 set indx [lindex $select 0] 3605 set disp {} 3606 foreach lbentry $config(ListBoxColumns,$inst) { 3607 set flist [lindex $lbentry 0] 3608 set disp "$disp [lindex $glob($inst,lv$flist) $indx]" 3609 } 3610 LogStatusOnly $disp 3611 } 3612 } 3613 # sum the sizes of the selected files (depends on size being #3) 3614 set n 0 3615 set s 0 3616 foreach k $select { 3617 set e [lindex $glob($inst,filelist) $k 3] 3618 if {[string is digit -strict $e]} { 3619 incr s $e 3620 } 3621 incr n 3622 } 3623 if {$s > 1048576} { 3624 set s [format "%.1fM" [expr $s/1048576.0]] 3625 } 3626 set len [llength $glob($inst,filelist)] 3627 if { $glob(enableautoupdate) != $oldena} { 3628 set glob(enableautoupdate) $oldena 3629 } 3630 $glob(win,$inst).top.stat configure -text \ 3631 "$n/$len = $s [lindex $glob($inst,df) 0]" 3632 # return indicates if there is a selection... 3633 return $n 3634} 3635 3636 3637proc ToggleSelect { inst } { 3638 global glob 3639 set selected [$glob(listbox,$inst).file curselection] 3640 $glob(listbox,$inst).file selection set 0 end 3641 foreach sel $selected { 3642 $glob(listbox,$inst).file selection clear $sel 3643 } 3644 propagateSelection $glob(listbox,$inst).file 3645 3646 UpdateStat 3647} 3648 3649 3650proc ShowListOnKey { inst char } { 3651 global glob config 3652 if {$char == ""} return 3653 # set foc [focus] 3654 # switch -glob $foc { 3655 # *entry* return 3656 # } 3657 # set inst "" 3658 # foreach in {left right} { 3659 # if {[$glob(listbox,$in).file curselection] != ""} {set inst $in} 3660 # } 3661 # if {$inst == ""} return 3662 if {$config(fileshow,sort) != {nameonly} } { 3663 set ask [smart_dialog .apop[incr ::uni] .\ 3664 [_ "Permission to change.."]\ 3665 [list [_ "Find on first character depends on sorting by 'nameonly'\ 3666 \nOK to set 'nameonly' sort mode and continue?"]]\ 3667 0 1 [_ "Yes"] [_ "No"]] 3668 if {$ask != 0} {return} 3669 set config(fileshow,sort) nameonly 3670 ForceUpdate 3671 } 3672 ShowListOnKey_ $glob(listbox,$inst).file glob($inst,filelist) "$char" 3673} 3674 3675proc ShowListOnKey_ { listb_name filelist_var char } { 3676 global glob config 3677 upvar $filelist_var filelist 3678 set first "" 3679 set last "" 3680 set mask $config(positiondirs) 3681 # For control characters we use the lower case version and 3682 # position as a directory entry. We ignor the positiondirs in this case. 3683 if {[string is control $char]} { 3684 scan $char %c num 3685 set char [format %c [expr {$num + 96}]] 3686 set mask 1 3687 } 3688 set case [expr {$config(sortoption) == "-ascii" ? "" : "-nocase"}] 3689 set n -1 3690 foreach k $filelist { 3691 incr n 3692 if {[IsFile $k] ^ $mask } { 3693 switch [eval "string compare $case -length 1 {$char} {[lindex $k 1]}"] { 3694 1 { continue} 3695 0 { if {$first == ""} {set first $n} 3696 set last $n 3697 continue 3698 } 3699 -1 { 3700 set last $n 3701 break 3702 } 3703 } 3704 } 3705 } 3706 # puts "first $first last $last n $n" 3707 if {$first != "" } { 3708 # This is an attempt to dodge the "near visable" thing that see does 3709 # We want to center the center of the found group This could be better... 3710 # by looking at total n (llength $filelist) 3711 if {$first > 60} { 3712 $listb_name see 0 3713 } else { 3714 $listb_name see end 3715 } 3716 $listb_name see [expr {($first + $last) / 2}] 3717 return 3718 } 3719 $listb_name see $n 3720} 3721 3722proc IsFile { elem } { 3723 return [expr {[lindex $elem 2] in {l n fl fn}}] 3724} 3725 3726 3727#----------------------------------------------------------------------------- 3728 3729# # The cascade menu. Does NOT work on windows. 3730 3731#----------------------------------------------------------------------------- 3732 3733proc DoBut {which inst index X Y} { 3734 global glob config 3735 set glob(doBut,index) $index 3736 set glob(doBut,inst) $inst 3737 set cmd $glob(bind,$which,$inst) 3738 lassign $cmd isocmd parm 3739 if {($glob(select_cur_lr) != $inst || $glob(select_cur_s) == {}) && \ 3740 $cmd ni $config(no_selection) && $inst != "glob" } { 3741 SelectThis $inst $index 3742 } 3743 if {$isocmd == "RaiseMenu" } { 3744 tk_popup $parm $X $Y 3745# puts "Raiseing menu $inst" 3746 return 3747 } 3748 DoProtCmd_NoGrab $cmd 3749} 3750 3751proc DoMenu { cmd inst {index 0} {X 0} {Y 0}} { 3752 global glob 3753 set glob(doBut,inst) $inst 3754 frputs "DoMenu >$cmd< $inst $glob(doBut,index) " 3755 DoProtCmd_NoGrab $cmd 3756} 3757 3758lappend glob(buttoncmds) {ViewOne ViewOne} {ViewDirOpposite ViewDirOpposite} \ 3759 {UpDirTree {UpDirTree $inst $X $Y}} {Back {Back $inst}} 3760 3761# Rather that repeat a hacked up version of CmdView 3762# we fake it into working with the file pointed to 3763# when the button was pressed. We do this by setting 3764# up a fake select function which returns the index. 3765 3766proc ViewOne {} { 3767 global glob 3768 set inst $glob(doBut,inst) 3769 $glob(listbox,$inst).file activate $glob(doBut,index) 3770# puts "Viewone $inst $glob(doBut,index)" 3771 CmdView_ SelectFake glob($inst,filelist) \ 3772 $glob($inst,pwd) $glob([Opposite $inst],pwd) $inst 3773} 3774 3775proc SelectFake {args} { 3776 global glob 3777 return $glob(doBut,index) 3778} 3779# 3780# The toggle function toggles config binary values. 3781# For use in 'bind' configure objects, 3782# e.g. config(bind,t) Toggle config(fileshow,all) 3783proc Toggle {what} { 3784 global config 3785 set $what [expr { ! [set $what]} ] 3786 ForceUpdate 3787} 3788 3789proc ViewDirOpposite {{selected 0}} { 3790 global glob 3791 set inst $glob(doBut,inst) 3792 if {$selected} { 3793 set sel [$glob(listbox,$inst).file curselection] 3794 if {$sel == {}} {return} 3795 lassign $sel ind x 3796 } else { 3797 set indx $glob(doBut,index) 3798 } 3799 set fileelem [lindex $glob($inst,filelist) $indx] 3800# puts "here $glob(doBut,inst) $glob(doBut,index) >$fileelem<" 3801 switch [lindex $fileelem 2] { 3802 wld { 3803 set newdir [TranslateLnk [wLinkName $inst $fileelem] \ 3804 [lindex $glob($inst,df) 1]] 3805 # frputs "TranslateLnk of [wLinkName $inst $fileelem] returns " newdir 3806 if {$newdir != {}} { 3807 NewPwd [Opposite $inst] $newdir 3808 UpdateWindow [Opposite $inst] 3809 } else { 3810 PopInfo [_ "Failed to translate windows lnk:\ 3811 %s" [wLinkName $inst $fileelem]] 3812 return 3813 } 3814 } 3815 fd - 3816 fld - 3817 ld - 3818 d { 3819 NewPwd [Opposite $inst] [DNtoDirTail $glob($inst,pwd)/[lindex $fileelem 1]] 3820 UpdateWindow [Opposite $inst] 3821 } 3822 } 3823} 3824 3825proc Opposite { inst } { 3826 return [expr {$inst == "left" ? "right" : $inst == "right" ? "left" : \ 3827 [error [_ "Internal error (%s)" $inst]]}] 3828} 3829 3830proc CheckAbort { info } { 3831 global glob 3832 update 3833 if { $glob(abortcmd) > 0} { 3834 Log [_ "%s aborted" $info] 3835 # This indicates that the abort was delivered... 3836 set glob(abortcmd) 0 3837 return 1 3838 } 3839 return 0 3840} 3841 3842proc CantDoThat { } { 3843 PopInfo [_ "It would be cool if FileRunner could do that, but it can't (yet)..."] 3844} 3845 3846proc DoUsrCmd { proc } { 3847 global glob 3848 set r [DoUsrCmd_ $glob(listbox,left).file \ 3849 glob(left,filelist) $glob(left,pwd) $glob(right,pwd) $proc] 3850 if {$r} { 3851 UpdateWindow both 3852 return 3853 } 3854 set r [DoUsrCmd_ $glob(listbox,right).file \ 3855 glob(right,filelist) $glob(right,pwd) $glob(left,pwd) $proc] 3856 if {$r} { 3857 UpdateWindow both 3858 return 3859 } 3860 Try {$proc {} $glob(right,pwd) $glob(left,pwd) $glob(mbutton)} 3861 UpdateWindow both 3862} 3863 3864proc DoUsrCmd_ { listb_name filelist_var frompwd topwd proc } { 3865 global config glob 3866 upvar $filelist_var filelist 3867 3868 set fl {} 3869 foreach sel [$listb_name curselection] { 3870 if {[CheckAbort "UserCommand $proc"]} return 3871 set elem [lindex $filelist $sel] 3872 lappend fl [lindex $elem 1] 3873 } 3874 if {$fl == ""} {return 0} 3875 Try {$proc $fl $frompwd $topwd $glob(mbutton)} 3876 return 1 3877} 3878 3879proc CheckWhoOwns { file action } { 3880 global config 3881 if {!$config(check_ownership)} { 3882 return 1 3883 } 3884 set r [CheckOwner $file] 3885 if {$r} {return 1} 3886 set r \ 3887 [smart_dialog .apop[incr ::uni] . "!" \ 3888 [list {} $file [_ " is not owned by you.\ 3889 \nOK to try to %s anyway?" $action ]]\ 3890 0 2 \ 3891 [list [_ "Yes"] [_ "No"]]] 3892 if {$r == 0} {return 1} 3893 return 0 3894} 3895 3896# 0 means yes 3897# 1 means no 3898# 2 means cancel or s/he destroyed the window 3899proc yesNoCancel {master title mess} { 3900 set r [smart_dialog .query[incr ::uni] $master $title \ 3901 [list $mess]\ 3902 0 3 [list [_ "Yes"] [_ "No"] [_ "Cancel"]]] 3903 return [expr {$r < 0 ? 2 : $r}] 3904} 3905 3906proc simple_smart_dialog {master title mess hint {cancel {}}} { 3907 # This just makes a common call to smart_dialog to get a new value for 3908 # 'hint'. master should be the master window, title the windows title, 3909 # mess the info message, and hint the suggested value. 3910 # return will be the new value for 'hint' which could be {} if 3911 # cancel or window abort or s/he actually clears the input field 3912 3913 set ::ssdTmp $hint 3914 set r [smart_dialog .window[incr ::uni] $master $title \ 3915 [list $mess] \ 3916 1 3 \ 3917 [list \ 3918 [list {} [list -textvariable ::ssdTmp -width 70]]\ 3919 [_ OK] [_ Cancel]] [buildDialogConfig] \ 3920 ] 3921 if {$r == -1 || $r == 2} { 3922 return $cancel 3923 } 3924 return $::ssdTmp 3925} 3926 3927proc cent {w m} { 3928 centerWin $w $m 3929 centerMouse2 $w.0 3930} 3931 3932proc FtpCheckSyntax { inst newpwd ask} { 3933 global glob config 3934 upvar newpwd newdir 3935 set newdir $newpwd 3936 set beenhere 0 3937# puts "$newdir" 3938 while { 1 } { 3939 set r [IsVFS $newdir] 3940 # puts "yet? match $match sftp $sftp VFStok $VFStok new $newpwd2 <" 3941 # By setting the cancel return to "/" we end up in a safe place. 3942 if {$r == 0 || $VFStok == ""} { 3943 set newdir [simple_smart_dialog "." \ 3944 [_ "Error in path"] \ 3945 [_ "Malformed URL: %s\nFormat:\ 3946 <protocol>://<user@site>/<path>\n\ 3947 Please edit new path or cancel." $newdir] \ 3948 $newpwd "/"] 3949 if { $newpwd == "" || ! [IsVFS $newpwd] } { 3950 # OK, the path was malformed and we got back nil, or a non-VFS path. 3951 # Go round again.. 3952 return -code continue $newdir 3953 } 3954 # Something that 'may' be a decent path, back up to test again... 3955 continue 3956 } 3957 if {$VFStok != "" && $VFSpath == ""} { 3958 set newdir $newdir/ 3959 } else { 3960 # we would like to do file normalize here, but it relates 3961 # ".." to [pwd] which is, well just not right in this 3962 # context. 3963 # set newdir [URL norm $newdir] 3964 } 3965# puts "$VFStok<>$sftp" 3966 set r [catch {OpenVFS $newdir} out] 3967 set posUp [URL norm $newdir/..] 3968 if {$r} { 3969 frputs "OpenVFS error " out ::errorInfo 3970 if {$out == "ABORT_LOGIN" } { 3971 LogStatusOnly [_ "$newdir login aborted"] 3972 # lets try the old dir here.... 3973 set newdir $glob($inst,pwd) 3974 return -code continue "" 3975 } 3976 if {$glob(debug)} { 3977 global errorInfo 3978 set info "\n errorInfo: $errorInfo" 3979 } else { 3980 set info "" 3981 } 3982 if {$ask == "goUp"} { 3983 set newdir $posUp 3984 return -code continue $newdir 3985 } 3986 3987 # again cancel get us to '/' 3988 set newdir [simple_smart_dialog "."\ 3989 [_ "Error Connecting"] \ 3990 [_ "Error: %s\n\nPlease edit new path or cancel." \ 3991 $out$info] \ 3992 $newdir "/"] 3993 if {$newdir == {}} { 3994 #s/he just wants to continue... 3995 set newdir $posUp 3996 return -code continue 3997 } 3998 if {! [IsVFS $newdir] } { 3999 return -code continue 4000 } 4001 # Still FTP but a new path, have another look here... 4002 continue 4003 } 4004 # Can we 'cd' to it? 4005 frputs out 4006 # if we have a new URL, use it 4007 if {[IsVFS $out]} { 4008 set newdir $out 4009 } 4010 set r [catch {VFScd $newdir} out] 4011 4012 # puts "VFS cd to $newpwd2 ret= $r" 4013 if {$r || $out != 1 } { 4014 # NO! 4015 if {$beenhere == 1} { 4016 TryMakeNewDir $newdir 4017 incr beenhere 4018 continue 4019 } 4020 # See if s/he can help us with the path... 4021 if {$glob(debug)} { 4022 global errorInfo 4023 set info "\n errorInfo: $errorInfo" 4024 } else { 4025 set info "" 4026 } 4027# puts "$r = r $out = out wd = $newpwd2" 4028 set newdir \ 4029 [simple_smart_dialog "." \ 4030 [_ "Error in path, can not cd to it"] \ 4031 [_ "Error: %s\nPlease edit new path or cancel.\ 4032 OK or Return will create it if it does not exist." $out$info] \ 4033 $newdir {}] 4034 # The following is in order to make sure the connection 4035 # to the VFS site is not lost even though we didn't get 4036 # the initial path correct. 4037 4038 set r [catch {VFSpwd $VFStok} out] 4039 if { $newdir == "" && $r == 0} { 4040 # s/he 4041 set newdir $out 4042 } 4043 frputs newdir r out 4044 if {$newdir == {}} { 4045 set newdir $posUp 4046 return -code continue 4047 } 4048 if { $newdir == "" || ! [IsVFS $newdir] } { 4049 return -code continue 4050 } 4051 set beenhere 1 4052 continue 4053 } 4054 break 4055 } 4056 4057 # If we always want the true path, get that 4058 if { $config(ftp,cd_pwd) } { 4059 set r [catch {VFSpwd $VFStok} out] 4060 if {!$r} { 4061 set glob(${inst},pwd) $out 4062 } else { 4063 # not sure here. we cd'd to the dir but failed the PWD??? 4064 PopError "$out" 4065 set newdir $glob($inst,pwd) 4066 return -code continue 4067 } 4068 } else { 4069 # Evaluate xxx/yyy/zzz/../.. to xxx 4070 set glob(${inst},pwd) [URL norm $newpwd] 4071 } 4072 set newdir $glob(${inst},pwd) 4073 return -code break 4074} 4075 4076 4077 4078proc AppendToDirHistory {dir} { 4079 global glob 4080 set found_index [lsearch -exact $glob(history) $dir] 4081 if { $found_index >= 0} { 4082 set glob(history) [lreplace $glob(history) $found_index $found_index] 4083 } 4084 set glob(history) [linsert $glob(history) 0 $dir] 4085 set glob(history) [lrange $glob(history) 0 30] 4086} 4087 4088 4089proc CreateHistoryMenu { inst } { 4090 global glob 4091 set menun $glob(win,$inst).dirmenu_frame.history_but.m 4092 $menun delete 0 end 4093 # while we are here, purge entries for dirs that do not exist. 4094 set newH {} 4095 foreach dir $glob(history) { 4096 if {![IsVFS $dir] && ![file exists $dir] && $dir != {}} {continue} 4097 $menun add command -label [dirToDN $dir] -command "CdHistory ${inst} \{$dir\}" 4098 lappend newH $dir 4099 } 4100 set glob(history) $newH 4101} 4102 4103proc CdHistory { inst dir } { 4104 global glob 4105 DoProtCmd " 4106 NewPwd ${inst} \{$dir\} 4107 UpdateWindow ${inst} 4108 " 4109} 4110proc ifExists {name file} { 4111 return [expr {[file exists $file] | [file exists $file.gz] ? \ 4112 [list [list [_ $name] $file]] : {}}] 4113} 4114proc CreateHelpMenu { } { 4115 global glob 4116 set thisMenu $glob(win,top).menu_frame.help_but.m 4117 $thisMenu delete 0 end 4118 buildCasMenu {}\ 4119 [list \ 4120 {*}[ifExists "QuickStart" $glob(doclib_fr)/QuickStart.txt]\ 4121 {*}[ifExists "User's Guide" $glob(doclib_fr)/Users_Guide.txt]\ 4122 {*}[ifExists "Copying" $glob(doclib_fr)/COPYING]\ 4123 {*}[ifExists "Eula" $glob(doclib_fr)/Eula]\ 4124 {*}[ifExists "History" $glob(doclib_fr)/HISTORY]\ 4125 {*}[ifExists "Installation" $glob(doclib_fr)/README]\ 4126 {*}[ifExists "FAQ" $glob(doclib_fr)/FAQ]\ 4127 {*}[ifExists "Tips" $glob(doclib_fr)/Tips.txt]\ 4128 {*}[ifExists "Known Bugs" $glob(doclib_fr)/KnownBugs.txt]\ 4129 {*}[ifExists "To Do" $glob(doclib_fr)/To_Do.txt]\ 4130 {*}[ifExists "inotify" $glob(conf_dir)/inotify-message]\ 4131 ] \ 4132 $thisMenu\ 4133 ViewTextH 4134} 4135 4136proc ViewTextH {file args} { 4137 ViewHelp $file 4138} 4139 4140proc CreateEtcMenu {w inst} { 4141 global glob 4142 # We only put up what is useful... 4143 set vfsMenu {} 4144 if {[IsVFS $glob($inst,pwd)]} { 4145 if {[catch {VFSmenu $VFStok} vfsMenu] != 0} { 4146 set vfsMenu {} 4147 } 4148 lappend vfsMenu \ 4149 {-label {Add To VFS Batch List} -command {AddToBatchList $inst}}\ 4150 {-label {View VFS Batch List} -command ViewBatchList}\ 4151 {-label {Clear VFS Batch List} -command {set glob(batchlist) {}}}\ 4152 {-label {VFS Copy With Resume} -command {P {CmdCopy 1}}}\ 4153 {-label {VFS Copy With Resume/Async} -command\ 4154 {set glob(async) "-a"; P {CmdCopy 1}}}\ 4155 {-label {HTTP Download} -command {P {CmdGetHttp $inst}}} 4156 } else { 4157 # Local file system 4158 lappend vfsMenu \ 4159 {+-label {Find File...} -command {P {CmdFind $inst}}}\ 4160 {+-label {Create Empty File...} -command {P {CmdCreateEmptyFile $inst}}}\ 4161 {+-label {Recurse Command...} -command {P {CmdRecurseCommand $inst}}}\ 4162 {-label {View VFS Batch List} -command ViewBatchList}\ 4163 {-label {Clear VFS Batch List} -command {set glob(batchlist) {}}}\ 4164 {-label {VFS Batch Receive} -command {P {BatchReceiveVFS $inst}}}\ 4165 {-label {HTTP Download} -command {CmdGetHttp $inst}} 4166 } 4167 $w delete 0 end 4168 ButtonAdd $w $inst $vfsMenu 4169} 4170 4171proc CreateHotListMenu {inst} { 4172 global glob config DNlist 4173 # We want to put the Display names first... 4174 set dnameList {} 4175 foreach {dir dname} $DNlist { 4176 lappend dnameList [list $dname $dir] 4177 } 4178 set dnameList [lsort -index 0 $dnameList] 4179 frputs dnameList 4180 buildCasMenu [list {} [list [_ "Dismiss"]] {} [list [_ "Add to hotlist"]] {}] \ 4181 [concat $dnameList [list {}] $config(hotlist)] \ 4182 $glob(win,$inst).dirmenu_frame.hotlist_but.m\ 4183 [list hotlistHandler $inst]\ 4184 -tearoffcommand FixTearoff\ 4185 filter dirToDN 4186} 4187proc hotlistHandler {inst dir list ent} { 4188 frputs ent dir list 4189 global glob config 4190 if {$list == 2} { 4191 DoProtCmd " 4192 NewPwd $inst [list $dir] 4193 UpdateWindow $inst 4194 " 4195 } else { 4196 if {$ent == 3} { 4197 set config(hotlist) [linsert $config(hotlist) 0 [list $glob($inst,pwd)]] 4198 } 4199 } 4200} 4201 4202proc getFileContent {filename content} { 4203 upvar $content MyContent 4204 if {[catch {open $filename r} fid] != 0} { 4205 PopError "$fid" 4206 return -code 2 4207 } 4208 # Here is a trick. If the file name ends with .gz or .zip, 4209 # put a conversion filter in place to decompress the file 4210 set ext [string tolower [file ext $filename]] 4211 if {$ext == ".zip"} { 4212 zlib push decompress $fid 4213 } elseif {$ext == ".gz"} { 4214 zlib push gunzip $fid 4215 } 4216 # Check file size here and if LARGE, ask... 4217 if {[set r [catch {file size $filename} an]] != 0 || $an > 1000000} { 4218 # over a megabyte, lets ask... 4219 if {$r != 0} { 4220 set mes "Error trying to get file size. Continue to try and display?" 4221 } else { 4222 set mes "File size is $an. Do you really want to try and display it?" 4223 } 4224 if {[yesNoCancel . {Really big} $mes] != 0} { 4225 return -code error "NoReport" 4226 } 4227 } 4228 if {[catch {read -nonewline $fid} MyContent] != 0} { 4229 PopError "$MyContent" 4230 catch {close $fid} 4231 return -code 2 4232 } 4233 close $fid 4234 return 4235} 4236 4237proc ViewText { filename {realName {}} args} { 4238 set realName [expr {$realName == {} ? $filename : $realName}] 4239 getFileContent $filename content 4240 frputs realName 4241 set title [_ "Viewing %s" $realName] 4242 foreach {item var} $args { 4243 set $item $var 4244 } 4245 ViewString $title content filename $realName 4246} 4247 4248proc undoHelp {w undo} { 4249 global glob 4250 catch {destroy .apop} 4251 set r [catch {$w edit $undo} err] 4252 if {$r} { 4253 smart_dialog .apop[incr ::uni] $w {Info} [list {} $err] \ 4254 0 0 {} [list -flashcolor $glob(gui,color_flash)] 4255 } 4256} 4257 4258# in ViewString 'args' (optional) list of pairs. Ones we recognize: 4259# filename <filename> defaults to {} 4260# SearchConfig <script> if present call script to set search options 4261# optionFlags boolean 0 to remove 'follow' from the <3> manu 4262# utf16 first element in the <3> menu, default is 'Convert UTF16' 4263# {} eliminates. Could also put something else here (but we don't) 4264# geo config(geometry,$geo) is used as window geometry (must exist) 4265# default is 'textviewer' intended option is 'qedit' 4266 4267proc ViewString { title var_string args} { 4268 global glob config 4269 upvar $var_string string 4270 set w .toplevel_$glob(toplevelidx) 4271 set filename {} 4272 # set minText "75x5" 4273 set SearchConfig {} 4274 set optionFlags 1 4275 set utf16 [list [_ "Convert UTF-16"] "ReReadUTF16 $w.text [list $filename]" ] 4276 set geo "textviewer" 4277 4278 foreach {item val} $args { 4279 set $item $val 4280 } 4281 4282 incr glob(toplevelidx) 4283 4284 # frputs "View String window " w 4285 toplevel $w 4286 wm att $w -alpha 0.0 4287 wm title $w "$title" 4288 wm iconname $w "$title" 4289 # wm geometry $w [getGeo $config(geometry,$geo) $w] 4290 wm protocol $w WM_DELETE_WINDOW "EditTextCheckPoint [list $filename] $w.text" 4291 # 4292 scrollbar $w.scroll -command "$w.text yview" 4293 text $w.text \ 4294 -relief sunken -bd 2 \ 4295 -yscrollcommand "$w.scroll set" \ 4296 -wrap word \ 4297 -undo 1 \ 4298 -font $glob(gui,ListBoxFont) \ 4299 -highlightthickness 0 4300 frputs "[$w.text cget -height] [$w.text cget -width] " 4301 button $w.quit\ 4302 {*}[getImage -bitmap cross @$glob(lib_fr)/bitmaps/cross.bit]\ 4303 -command "destroy $w"\ 4304 -width 11\ 4305 -height 11\ 4306 -bd 1 4307 4308 set seGrip [segrip $w] 4309 set swGrip [swgrip $w] 4310 $swGrip config -width 3 -height 3 -anchor sw 4311 grid $w.quit -in $w -row 3 -column 2 -sticky news 4312 grid $w.quit -row 3 -column 2 -sticky ne 4313 grid $w.scroll -in $w -row 4 -column 2 -columnspan 2 -sticky nse 4314 grid $seGrip -in $w -row 5 -column 2 -sticky se 4315 grid $swGrip -in $w -row 5 -column 0 -sticky sw 4316 grid $w.text -in $w -row 3 -column 0 -rowspan 3 -sticky news 4317 grid columnconfig $w 0 -weight 1 4318 grid rowconfig $w 4 -weight 1 4319 $w.text insert 0.0 $string 4320 $w.text mark set insert 0.0 4321 $w.text edit reset 4322 $w.text edit modified 0 4323 ::autoscroll::autoscroll $w.scroll 4324 destroy $w.text.p 4325 intelWinSize $config(geometry,$geo) $w.text 4326 wm att $w -alpha 1.0 4327 set redo [expr {$::MSW ? "C-y" : "C-Z"}] 4328 if {$SearchConfig == {}} { 4329 textSearch $w.text "$title" "+buildViewConfig ViewEditStrings" \ 4330 [list {*}$utf16]\ 4331 [list [_ "Undo"] [list ? "undoHelp $w.text undo" -accelerator C-z]\ 4332 [_ "Redo"] [list ? "undoHelp $w.text redo" -accelerator $redo] \ 4333 {*}[spellCheckText $w.text -log LogStatusOnly -file $filename\ 4334 -filter $config(spellingFilter)\ 4335 -expect $config(spellcheck,expect)]\ 4336 {*}[ViewOptionsIfFile $filename $w $optionFlags]\ 4337 [_ "Save As..."] [list ? [list SaveToFile $w.text $filename 1] \ 4338 -accelerator C-S]\ 4339 [_ Quit] [list ? [list EditTextCheckPoint $filename $w.text]\ 4340 -accelerator C-q]] 4341 4342 #bind $w.text <Control-s> [list SaveToFile $w.text $filename 0] 4343 bind $w.text <Control-S> [list SaveToFile $w.text [list $filename] 1] 4344 bind $w.text <Control-q> [list EditTextCheckPoint [list $filename] $w.text] 4345 } else { 4346 eval [list {*}$SearchConfig $w $title $filename $var_string] 4347 } 4348 bind $w.text $config(mwheel,neg) \ 4349 "$w.text yview scroll -$config(mwheel,delta) units;break" 4350 bind $w.text $config(mwheel,pos) \ 4351 "$w.text yview scroll $config(mwheel,delta) units;break" 4352 # window name is returned for use by the log code. 4353 return $w 4354} 4355 4356# Come here when the window is being wiped and it has been modified 4357proc reallyDone {w} { 4358} 4359 4360# option is true if 'follow option is desired' 4361proc ViewOptionsIfFile {filename w options} { 4362 # These options only make sense if there is a filename... 4363 if {$filename != {}} { 4364 bind $w.text <Control-s> [list SaveToFile $w.text $filename 0] 4365 lassign [split [$w.text index "end-1 chars"] "."] next 4366 if {$options} { 4367 lappend ret [_ "Follow end"] [list followFile $w.text $filename $next] 4368 } 4369 return [lappend ret \ 4370 [_ "Revert File"] [list ReRead $w $filename] \ 4371 [_ "Save" ] [list ? [list SaveToFile $w.text $filename 0] \ 4372 -accelerator C-s]\ 4373 [_ "Save&Quit"] [list SaveEditedText $filename $w.text]] 4374 } 4375 return {} 4376} 4377 4378proc ReRead {w filename} { 4379 set index [$w.text index current] 4380 if {[$w.text edit modified]} { 4381 set r [yesNoCancel $w.text [_ "What to do?"]\ 4382 [_ "This will destroy your changes. Do you want to continue?"]] 4383 if {$r != 0} { 4384 focus $w 4385 return 4386 } 4387 } 4388 getFileContent [lindex $filename 0] content 4389 $w.text delete 0.0 end 4390 $w.text insert 0.0 $content 4391 $w.text mark set current $index 4392 $w.text edit reset 4393 $w.text edit modified 0 4394} 4395 4396proc ReReadUTF16 {w filename } { 4397 set txt [regsub -all {\x00} [$w get 1.0 end] {}] 4398 $w replace 1.0 end $txt 4399 $w mark set insert 0.0 4400} 4401 4402 4403proc SaveToFile { w filename ask args } { 4404 # undo any "list" mods: 4405 set filename [lindex $filename 0] 4406 frputs w filename ask args 4407 global env glob 4408 if {$ask || $filename == {}} { 4409 if {$filename == {}} { 4410 set filename $env(HOME)/ 4411 } 4412 set filename [simple_smart_dialog $w [_ "What file?"]\ 4413 [_ "Enter name of file to save to"] $filename] 4414 if {$filename == ""} {return 0} 4415 } else { 4416 if {$filename == ""} {PopError [_ "Null filename"]} 4417 } 4418 set tmpFile $filename 4419 set r 0 4420 if {[IsVFS $filename]} { 4421 # For VFS we first save it in a tmp area 4422 if { ! [file exists $glob(tmpdir)] } { 4423 set r [Try { file mkdir $glob(tmpdir) }] 4424 } 4425 if {$r} { 4426 PopError [_ "Failed to create %s " $glob(tmpdir)] 4427 return 1 4428 } 4429 set tmpFile $glob(tmpdir)/[file tail $filename] 4430 } 4431 frputs w tmpFile 4432 set r [Try { 4433 set fid [open $tmpFile w] 4434 puts -nonewline $fid [$w get 0.0 end] 4435 close $fid}] 4436 4437 if {!$r && $tmpFile != $filename} { 4438 # Now put the file to the VFS location 4439 set r [Try {VFSputFile $filename $tmpFile [file size $tmpFile] }] 4440 } 4441 if {$r} { 4442 return 1 4443 } 4444 $w edit modified 0 4445 Log [_ "Saved: %s" $filename] 4446 UpdateIf $filename 4447 return 0 4448} 4449 4450proc EditText {filename {realName {}}} { 4451 set realName [expr {$realName == {} ? $filename : $realName}] 4452 getFileContent $filename content 4453 set w [ViewString [_ "Editing %s" $filename] content \ 4454 filename $realName \ 4455 optionFlags 0 \ 4456 utf16 {}\ 4457 geo qedit] 4458 set size_file [file size $filename] 4459 set size_text [string length [$w.text get 0.0 end]] 4460 if { $size_file != $size_text } { 4461 PopWarn [_ "Editing:\nCharacters lost/added when converting\ 4462 %s to text.\nOld size: %s\nNew Size: %s" $filename $size_file $size_text] 4463 # puts "call2 $w" 4464 } 4465} 4466 4467# w should be the text window... 4468proc EditTextCheckPoint { filename w } { 4469 global config 4470 frputs filename w 4471 # Ask about saving only if modified 4472 if {![winfo exists $w]} { 4473 # puts "EditTextCheckPoint $filename $w" 4474 return 4475 } 4476 # puts "$w [$w.text edit modified]" 4477 if {[$w edit modified] && \ 4478 ($filename != {} || $config(ask,save_modified_file))} { 4479 set ms [_ "Do you want to save before exiting?"] 4480 append ms\ 4481 [expr {$config(ask,save_modified_file) && $filename == {} ? \ 4482 [_ "\n(Disable with \"config(ask,save_modified_file)\" option.)"]\ 4483 : {}}] 4484 set r [smart_dialog .editq[incr ::uni] $w [_ "What to do?"]\ 4485 [list $ms]\ 4486 0 3 [list [_ "Yes"] [_ "No"] [_ "Cancel"]]] 4487 switch $r { 4488 0 { SaveEditedText $filename $w} 4489 1 { catch { destroy [winfo parent $w] } } 4490 default {} 4491 } 4492 } else { 4493 catch { destroy [winfo parent $w] } 4494 } 4495} 4496 4497proc SaveEditedText { filename w } { 4498 if {! [SaveToFile $w $filename 0]} { 4499 catch {destroy [winfo parent $w]} 4500 } 4501 UpdateWindow both 4502} 4503 4504proc VFSEntryDialog { wm_title info_text start_entry } { 4505 global glob 4506 4507 set glob(.vfs_usr) $start_entry 4508 set glob(.vfs_showpw) 0 4509 set rt [smart_dialog .vfs_entry_dialog[incr ::uni] . $wm_title \ 4510 [list [_ "%s\n\nOK activates, cancel or window-delete cancels."\ 4511 $info_text]]\ 4512 2 5 \ 4513 [list \ 4514 [list [_ "Username:"] {-textvariable glob(.vfs_usr)}]\ 4515 [list [_ "Password:"] {-textvariable glob(.vfs_paswd) \ 4516 -show "*" }]\ 4517 [list [_ "OK"]]\ 4518 [list [_ "Show password"] \ 4519 {-variable glob(.vfs_showpw) -command vfsPwShow}]\ 4520 [list [_ "Cancel"]]\ 4521 ]\ 4522 [buildDialogConfig]\ 4523 ] 4524 if {$rt == -1 || $rt == 4} {return {}} 4525 return [list $glob(.vfs_usr) $glob(.vfs_paswd)] 4526} 4527 4528proc vfsPwShow {} { 4529 global glob 4530 set showChar [expr {$glob(.vfs_showpw) ? {} : {*}}] 4531 .vfs_entry_dialog.1 config -show $showChar 4532} 4533 4534# This little proc is passed to frECF as a post routine to post 4535# the the result in a ViewString window or what ever... 4536# At this point we only handle call by name for the data which 4537# works fine with ViewString ... 4538 4539proc postOptions {where nodata data} { 4540 upvar $data string 4541 # frputs where nodata data string 4542 4543 if {[string index $where end-1] == "&" && \ 4544 [regexp {^[0-9 \n]*} $string] } { 4545 # background and only pids reported back 4546 return 4547 } 4548 4549 if {$string == {}} { 4550 if {$nodata != "nop"} { 4551 eval [list {*}$nodata] 4552 } 4553 return 4554 } 4555 eval [list {*}$where string] 4556} 4557 4558# The ViewAny routine is called (among other places) from open where, 4559# if in windows, we want the orgional filename to pass to the windows cmd 4560# thus, in that case, we hope to find an original file name in filenameorg 4561# which should be the same as filenamelist except in the case of a lnk file. 4562 4563proc ViewAny { filenamelist {extensionList view} {filenameorg {}}} { 4564 global glob config 4565 #puts $filenamelist 4566 set firstfile [lindex $filenamelist 0] 4567 if {$firstfile == {}} {return} 4568 frputs "ViewAny file name list " filenamelist 4569 while {[incr try] <= 2} { 4570 set found "" 4571 foreach k $config($extensionList,extensions) { 4572 foreach l [lindex $k 1] { 4573 if {[string match -nocase $l "$firstfile"]} { 4574 set found [lindex $k 0] 4575 break 4576 } 4577 } 4578 if {$found != ""} break 4579 } 4580 if {[string match -nocase $found "try open"] && $extensionList == "view"} { 4581 set extensionList "open" 4582 continue 4583 } 4584 break 4585 } 4586 if {$found != ""} { 4587 if {[lindex $k 2] == "-viewtext"} { 4588 foreach file $filenamelist { 4589 Log "Running exec [subst {*}$::stOps $found] $file" 4590 frECF [list exec {*}[subst {*}$::stOps $found]]\ 4591 [list $file]\ 4592 [list -post \ 4593 [list postOptions [list ViewString [_ "Viewing %s" $file]] nop]] 4594 } 4595 } else { 4596 frECF [list exec {*}[subst {*}$::stOps $found] %b &] \ 4597 $filenamelist 4598 } 4599 return 4600 } 4601 4602 # Ok, we did not trap it above. Try the open trick. 4603 if { $extensionList == "view" } { 4604 foreach filename $filenamelist { 4605 ViewText $filename $filenameorg 4606 } 4607 return 4608 } 4609 # if the file is executable, do that, else call the open thing 4610 # here is the only place we care about the filenameorg list 4611 set index -1 4612 set file {} 4613 foreach filename $filenamelist { 4614 incr index 4615 # set file [FixFileNameO [file native $filename] 1 {\[ $} ] 4616 frputs "in viewany- open " filename "-> " file index 4617 if {! $::MSW && [file executable $filename ]} { 4618 # verify executable by checking mime type 4619 Log "exec file -b $filename" 4620 # set r [catch [ReSpaceString "exec file -b" "$file"] out] 4621 set rr [frECF {exec file -b} [list $filename]] 4622 lassign $rr r out 4623 frputs "After frECF: " out r 4624 if {$r == 0} { 4625 if { [string match {*executable*} $out] && \ 4626 ![string match {*MS Windows*} $out]} { 4627 Log "exec $filename &" 4628 set rr [frECF {exec %b &} [list $filename]] 4629 # set r [catch [ReSpaceString "exec" "$file &"] out] 4630 } 4631 } 4632 } else { 4633 if {$::MSW && $filenameorg != {}} { 4634 # on windows, execute the original *.lnk if available 4635 set filename [lindex $filenameorg $index] 4636 } 4637 set cmd [list exec {*}[subst {*}$::stOps $config(cmd,open)] %b &] 4638 # see if we can find a proper file to run this with.. 4639 if {$::MSW && [set cmdt [windowsAutoExecOk $filename]] != {}} { 4640 # if 'windowsAutoExecOk' passes something back it is either the 4641 # whole string to run or what to execute & the parm. This should 4642 # work either way... 4643 lassign $cmdt cmd file 4644 set cmd [list exec {*}$cmd %s &] 4645 frputs cmdt cmd file 4646 } 4647 set rr [frECF $cmd [list $file]] 4648 } 4649 lassign $rr r out 4650 if {$r != 0} { 4651 Log "error: $out" 4652 } 4653 } 4654 return 4655} 4656 4657 4658 4659proc UnArcPackAny { file dir which} { 4660 global config glob 4661 set found "" 4662 foreach k $config(cmd,$which,extensions) { 4663 foreach l [lindex $k 1] { 4664 if {[string match [string tolower $l] [string tolower "$file"]]} { 4665 set found $k 4666 break 4667 } 4668 } 4669 if {$found != ""} break 4670 } 4671 if {$found == ""} { 4672 PopWarn [_ "Cannot find %s rule for %s" $which $file] 4673 return 4674 } 4675 frputs file "[subst [lindex $k 0]] " k 4676 cd $dir 4677 if {$::MSW} { 4678 fixMSWcommand [list exec {*}[subst {*}$::stOps [lindex $k 0]]]\ 4679 [list $file]\ 4680 [list -b $glob(async)] 4681 } else { 4682 frECF [list exec {*}[subst {*}$::stOps [lindex $k 0]]]\ 4683 [list $file] \ 4684 [list -b $glob(async)] 4685 } 4686 # set ex [format [FixFormatString [lindex $k 0]] \ 4687 # [FixFileNameO [file native $file] 3 {\[ $}]] 4688 # set cmd [ReSpaceString exec $ex] 4689 # 4690 # frputs "unArc/Pack command: " cmd 4691 # Try $cmd "" 1 $glob(async) 4692} 4693 4694proc TabBind { list } { 4695 set i [lsearch -exact $list [focus]] 4696 incr i 4697 if {$i >= [llength $list]} { 4698 set i 0 4699 } 4700 catch {focus [lindex $list $i]} out 4701 # catch {[lindex $list $i] } 4702} 4703 4704 4705proc PopInfo { info } { 4706 smart_dialog .apop[incr ::uni] . [_ "Info"] [list $info] 0 1 [_ "OK"] 4707 #LogSilent "**Info**\n$info" 4708} 4709 4710proc PopWarn { warn } { 4711 global glob errorInfo 4712 if {$glob(debug)} { 4713 set this "*[regsub {\n.*} $errorInfo {}]*" 4714 if {[string match $this $warn]} { 4715 append warn "\n$errorInfo" 4716 } 4717 } 4718 smart_dialog .apop[incr ::uni] . [_ "Warning"] [list $warn] 0 1 [_ "OK"] 4719 LogStatusOnly "[lindex [split $warn \n] 0]" 4720 LogSilent [_ "**Warning**\n%s" $warn] 4721} 4722 4723# The Clean proc destroys all toplevel windows except the 4724# Error window. 4725 4726proc Clean {} { 4727 foreach win [winfo children .] { 4728 if {[string match ".toplevel_*" $win]} { 4729 destroy $win 4730 } 4731 } 4732} 4733 4734proc PopError { error } { 4735 global glob config errorInfo 4736 # tk_dialog_fr .apop "**Error**" "$error" "" 0 "OK" 4737 # Try view instead. Doesn't truncate error messages, cutable, saveable 4738 # a "good thing" tm 4739 # Even more, lets use just one window for all error messages... 4740 4741 frputs #2 #1 "PopError " error 4742 set er "" 4743 if {![info exists glob(errorWindow)] || ![winfo exists $glob(errorWindow)]} { 4744 set glob(errorWindow) [ViewString [_ "**Error**"] er ] 4745 set w $glob(errorWindow) 4746# puts "window name is >$w<" 4747 wm protocol $w WM_DELETE_WINDOW \ 4748 PopErrorClean 4749 $w.quit configure \ 4750 -command PopErrorClean 4751 # Rewrite the 'Quit' command to save the window 4752 $w.text.p entryconfigure last \ 4753 -command PopErrorClean 4754 $w.text.p insert 1 command \ 4755 -label {Clear error window} \ 4756 -command "$w.text delete 0.0 end" 4757 bind $w <Escape> PopErrorClean 4758 # $w.text insert end [_ "Error window"] 4759 } 4760 set w $glob(errorWindow) 4761 if {$error != {}} { 4762 set error [regsub -all {\r} $error {}] 4763 set errorInfo [regsub -all {\r} $errorInfo {}] 4764 $w.text mark set insert end 4765 $w.text insert end "\n=============\n$error" 4766 if {$glob(debug)} { 4767 $w.text insert end "\n==errorInfo==\n${errorInfo}" 4768 } 4769 LogStatusOnly "[lindex [split $error \n] 0]" 4770 LogSilent [_ "**Error**\n%s" $error] 4771 } 4772 $w.text see end 4773 wm withdraw $w 4774 # resize the window 4775 intelWinSize $config(geometry,textviewer) $w.text min fxa2 4776 wm deiconify $w 4777 $w.text.p unpost 4778# ViewString "**Error**" error "" 4779} 4780proc PopErrorClean {} { 4781 global glob 4782 wm withdraw $glob(errorWindow) 4783 # clean up any lingering tearoffs 4784 eval {eval [bind $glob(errorWindow) <Destroy>]} 4785} 4786# This is a companion to the Try code. It manages the "Stop" button 4787# and keeps track of the number of async streams we have at any one time 4788# proc endAsync {} { 4789# global glob 4790# if {[incr glob(asyncCount) -1] <= 0} { 4791# set glob(asyncCount) 0 4792# # $glob(win,top).menu_frame.abort config -state disabled 4793# } 4794# } 4795 4796# This is a two part (i.e. proc) set up that launches and 4797# keeps track of (well for now, it knows when it ends) an async 4798# function call. It is assumed that we get the 'script' to be 4799# executed which may have function calls and variable references 4800# in it. These calls and variables are dereferenced using 'subst' 4801# at the callers 'level' in the stack before the 'after 0' call 4802# which actually launches the async execution. The script is 4803# dereferenced at 'level' which defaults to 1. The 'level' 4804# parameter is provided for cases where the caller is a function 4805# acting on behalf of its caller. 4806 4807# The script is "added to" with a call to 'endAsync' which clocks 4808# the async code out (notes that it completed). Also the script 4809# is executed in a 'catch' environment to allow us the trap 4810# errors. 4811 4812proc tendAsync {script args} { 4813 global glob 4814 # we are in the async mode... 4815 frputs script 4816 # We catch errors so we can allow "error" on async stop 4817 # and to preserve some semblance of the asyncCount 4818 4819 # At any given time there will be 'asyncCount' tasks running 4820 # The 'index' at level 1 (this level) points to the task's task 4821 # in ::asyncTasks which will be empty if no async tasks are running. 4822 4823 # For async tasks which are polling we can set a flag they can find 4824 # using the value of index after 'upvar #1 index index' or 4825 # 'uplevel #1 {set index}' 4826 if {[set index [incr glob(asyncCount)]] >= 1} { 4827 $glob(win,top).menu_frame.async config\ 4828 -text [_ "Async %s" $glob(asyncCount)]\ 4829 -bg $glob(gui,color_highlight_fg) 4830 } 4831 set ::asyncTasks($index) $script 4832 set r [catch {eval $script} out options] 4833 4834 # End of async command. Dec the count and check for errors 4835 if {[incr glob(asyncCount) -1] <= 0} { 4836 set glob(asyncCount) 0 4837 $glob(win,top).menu_frame.async config -bg $glob(gui,color_scheme) 4838 } 4839 unset ::asyncTasks($index) 4840 $glob(win,top).menu_frame.async config -text [_ "Async %s" $glob(asyncCount)] 4841 4842 if {$r == 0} {return} 4843 # 4844 # Some sort of error, could be an "async Stop" 4845 # 4846 frputs out "[info level] " ::errorInfo 4847 if {[string match {*async abort*} $out]} { 4848 set glob(abortcmd) 0 4849 LogSilent "Async Stop: $out" 4850 return 4851 } 4852 TryReportErrors $out $args 4853 return 4854} 4855 4856# The CmdAbort commad is called by the "Stop" button. 4857# If the "DoProtProc" level is zero and the async count 4858# is 0, it resets "glob(abortcmd)". 4859# Otherwise it waits for both of these to go to zero 4860# and then resets "glob(abortcmd)". 4861# During this time it will ... 4862proc CmdAbort {} { 4863 global glob 4864 incr glob(abortcmd) 4865 #focus $glob(win,top).status 4866 #frgrab $glob(win,top).menu_frame.fasync_cmds 4867 set curser [. cget -cursor] 4868 . config -cursor circle 4869 while {$glob(abortcmd) != 0 && ($::DoProtLevel != 0 || $glob(asyncCount) != 0)} { 4870 realWaitForIdle 4871 } 4872 #catch {grab release [grab current $glob(win,top).menu_frame.fasync_cmds]} 4873 frputs 4874 . config -cursor $curser 4875 set glob(abortcmd) 0 4876} 4877 4878# Try returns 0 if no error, else 1 4879# Lets try a cleaner interface: 4880# Was: tryscript<script> excuse<string> alsoPrintError<bool> ?async <bool>? 4881# Now: tryscript<script> args.. 4882# Where args: each one of: -s<string> or -q or -a or 4883# as the old call. 4884# The -q means no error print, the majority of calls want errors printed 4885# also the majority have no "excuse" string. 4886# Because of the need to evaluate variables (i.e. $v substution) in the callers 4887# context and, if "async" to run in a different context we have some rules on the 4888# construction of the "Try" script: 4889# 4890# 1.) do NOT put protected commands (i.e.{... [command...]...}) in the script. 4891# 2.) do NOT use {*} in the script, use quotes and not {} and the {*} is not 4892# needed. I.e. {*} fails and {$x} where $x need to have {*}$x fails, but 4893# "$x" does the right thing. 4894# 3.) more than one command is ok but they should be seperated in 1 of 2 ways: 4895# if the script is in quotes, put semicolons between them. If the script is 4896# protected, i.e. { script } just put in new lines. 4897 4898# In short, enclose the script in quotes, avoid {*} (not needed) and seperate 4899# commands with ;'s. 4900 4901 4902# proc Try { tryscript excuse alsoPrintErrorInfo {async 0} } {} 4903proc Try {tryscript args} { 4904 global glob 4905 frputs #2 tryscript args 4906 if {[lindex $args 2] == 1 || "-a" in $args} { 4907 # If this is an exec command we use "&" for async 4908 # If not we will use "after 0" to launch the command 4909 # In this case we also keep track of how many we have out 4910 4911 if {[string match "*exec*" $tryscript] &&\ 4912 [string index $tryscript end] != "&"} { 4913 append tryscript " &" 4914 } else { 4915 # A lot of sweat went into the following line.... 4916 set deRcmd [uplevel subst [list [list {*}$tryscript]]] 4917 frputs deRcmd 4918 set deRcmd [regsub -all {{;}} $deRcmd {;}] 4919 frputs deRcmd tryscript 4920 after 0 [list tendAsync $deRcmd $args] 4921 return 0 4922 } 4923 } 4924 set tryscript [regsub -all {{;}} $tryscript {;}] 4925 if {[catch {uplevel $tryscript} outp] == 0} {return 0} 4926 frputs outp ::errorInfo 4927 return [TryReportErrors $outp $args] 4928} 4929 4930proc TryReportErrors {outp arg} { 4931 4932 if {$::glob(abortcmd) > 0} { 4933 LogSilent "Ignoring error: $::errorInfo" 4934 return 0 4935 } 4936 4937 # This is a really ugly hack, but I don't care... I can't 4938 # see another way around this. Email me if you got a solution. 4939 # (Problem shows up in Linux when unarchiving .tar.gz files 4940 # and the error is completely harmless) 4941 4942 if {$outp == "child killed: write on pipe with no readers"} { 4943 return 0 4944 } 4945 # Time to decode the rest of the args 4946 # We know there is no "async flag" left... but we share so... 4947 set excuse {} 4948 set index -1 4949 set np 0 4950 foreach val $arg { 4951 incr index 4952 switch -exact [string range $val 0 1] { 4953 -s {set excuse [string range $val 2 end]} 4954 1 - 4955 -q {incr np} 4956 -a - 4957 0 {} 4958 default { 4959 if {$index == 0} {set excuse $val} 4960 } 4961 } 4962 } 4963 4964 if {!$np} { 4965 if {$excuse != ""} { 4966 PopError "$excuse\n$outp" 4967 } else { 4968 PopError "$outp" 4969 } 4970 } else { 4971 if {$excuse != ""} { 4972 PopError "$excuse" 4973 } 4974 } 4975 4976 return 1 4977} 4978 4979proc StartTerm { inst } { 4980 global glob config 4981 set dir $glob($inst,pwd) 4982 Try {cd $dir; eval exec [format $config(cmd,term) $dir] & } 4983} 4984 4985 4986 4987proc getOldNewVersions {} { 4988 global glob 4989 set r [catch {source $glob(conf_dir)/version} out] 4990 if {$r} { 4991 set version 00.00.00.00 4992 } 4993 # This is here to take care of old format version strings... 4994 if {![string match {[0-9][0-9].[0-9][0-9].[0-9][0-9].[0-9][0-9]} $version]} { 4995 set version 00.00.00.00 4996 } 4997 # puts "[list $version $glob(version)] >$version $glob(version)" 4998 4999 # take the "."s out... resolve to day only 5000 set oldv [string range [regsub -all {\.} $version {} ] 0 end-2] 5001 set newv [string range [regsub -all {\.} $glob(Sversion) {} ] 0 end-2] 5002 return [list $oldv $newv] 5003} 5004 5005proc ShowRev { } { 5006 global glob env 5007 lassign [getOldNewVersions] oldv newv 5008 if {$newv > $oldv} { 5009 About 5010 # show the history on a new rev 5011 set r [catch { 5012 set fid [open $glob(conf_dir)/version w] 5013 puts $fid "set version $glob(Sversion)" 5014 close $fid 5015 }] 5016 if {$r} { 5017 PopWarn [_ "Cannot create %s/version" $glob(conf_dir)] 5018 } 5019 return 1 5020 } 5021 return 0 5022} 5023 5024 5025# This logs to the log window and the top status bar. 5026proc Log { text } { 5027 global glob 5028 # Clean any returns from the string (usually from expect) 5029 set text [regsub -all {\r} $text {}] 5030 # It is possible to get here before we are up and ready 5031 # lets cache such lines and do them later 5032 lappend ::DeferedLog $text 5033 if {[info exist glob(init_done)] && $glob(init_done)} { 5034 foreach mes $::DeferedLog { 5035 LogStatusOnly $mes 5036 LogSilent $mes 5037 } 5038 unset ::DeferedLog 5039 } 5040} 5041 5042# This logs only to the top window status frame 5043proc LogStatusOnly { text } { 5044 global glob 5045 set w $glob(win,top).status 5046 if { [winfo exists $w]} { 5047 set fsize [font measure [$w cget -font] -displayof $w "O"] 5048 set last {} 5049 set text [regsub -all {\n|\r} $text { }] 5050 set new [string trim [$w cget -text]] 5051 # frputs text "[string range $new end-2 end] " 5052 if {$text == "U" && [string range $new end-2 end] == "U ."} {return} 5053 if {$text == "." && [string range $new end-2 end] == "U ."} {return} 5054 5055 append new " $text" 5056 set len [string length $new] 5057 lassign [split [winfo geo $w] x+] width 5058 set over [expr {$len - ($width / $fsize)}] 5059 if {$over >= 0} { 5060 set new [string range $new $over+1 end] 5061 } 5062 $w config -text $new 5063 } else { 5064# puts "$text" 5065 PopError $text 5066 } 5067} 5068 5069proc ViewLog {} { 5070 global glob env 5071 # Not sure it makes sense to provide a file name here. 5072 # It, most likely, does not exist. 5073 lappend glob(log_window) [ViewString [_ "Log"] glob(log)] 5074} 5075 5076# The following writes to the log text window 5077proc LogSilent { text } { 5078 global glob config 5079 frputs #2 #1 "LOG: " text 5080 set glob(log) "$glob(log)---[Time]---\" $text\"\n" 5081 set len [string length $glob(log)] 5082 if { $len > $config(logsize) } { 5083 set glob(log) \ 5084 "...[string range $glob(log)\ 5085 [expr $len - (($config(logsize) * 4) / 5)] end]" 5086 } 5087 if {[info exists glob(log_window)] } { 5088 set new {} 5089 foreach w $glob(log_window) { 5090 if {[catch {wm attributes $w} ] == 0} { 5091 $w.text insert end "---[Time]---\" $text\"\n" 5092 $w.text see end 5093 lappend new $w 5094 } 5095 } 5096 set glob(log_window) $new 5097 } 5098} 5099 5100 5101proc CleanUp { ret } { 5102 global env config glob 5103 catch {file delete -force -- $glob(tmpdir)} 5104 if { $ret } { 5105 puts [_ "FileRunner: aborting (return code %s)" $ret] 5106 bgerror $ret 5107 while {1} {update} 5108 } 5109 # save history to disk 5110 set r [catch { 5111 set fid [open $glob(conf_dir)/history w] 5112 puts $fid $glob(history) 5113 close $fid 5114 } out] 5115 if {$r} { 5116 puts [_ "FileRunner: Can't save directory history to disk: %s" $out] 5117 } 5118 if { $config(save_conf_at_exit) && !$r && !$ret } { 5119 SaveConfig 5120 } 5121 exit $ret 5122} 5123 5124proc Time {} { 5125 global config 5126 if { $config(dateformat) == "yymmdd" } { 5127 return "[clock format [clock seconds] -format %y%m%d\ %R]" 5128 } elseif {$config(dateformat) == "ddmmyy" } { 5129 return "[clock format [clock seconds] -format %d%m%y\ %R]" 5130 } else { 5131 return "[clock format [clock seconds] -format $config(dateformat)]" 5132 } 5133} 5134 5135proc TimeUpdater {} { 5136 global glob 5137 $glob(win,top).menu_frame.clock configure -text "[Time] " 5138 after 30000 TimeUpdater 5139} 5140 5141proc ClearWatch { inst newdir } { 5142 global glob config 5143 if { $glob(inotify_flags) != {} } { 5144 if {$glob(notify,$inst) != $newdir} { 5145 if {$glob(notify,left) != $glob(notify,right) } { 5146 if {[catch {$glob(notify,watchname) remove $glob(notify,$inst)} out] != 0} { 5147 frputs out 5148 } 5149 } 5150 set glob(notify,$inst) $newdir 5151 if {$glob(notify,left) != $glob(notify,right) } { 5152 set notifyFlags [expr { ! [NonLocalDir $newdir] ? $config(inotify_flags) :\ 5153 $config(inotify_nlflags)}] 5154 if {$notifyFlags != {} && \ 5155 [catch {$glob(notify,watchname) add $glob(notify,$inst)\ 5156 $notifyFlags} out] == 0 } { 5157 set glob(notify_id,$inst) $out 5158 } elseif {$notifyFlags != {} } { 5159 frputs out 5160 } 5161 } else { 5162 set glob(notify_id,$inst) $glob(notify_id,[Opposite $inst]) 5163 } 5164 } 5165 } 5166} 5167# 5168 5169set glob(capture_dir,left) [set glob(capture_pwd,left) ""] 5170set glob(capture_dir,right) [set glob(capture_pwd,right) ""] 5171 5172 5173proc ClearCherryPicker { inst } { 5174 global glob 5175# puts "clear $inst" 5176 set glob(n_file_cache,$inst) {} 5177 set glob(n_files,$inst) {} 5178} 5179 5180proc WakeListUpdater { args } { 5181 global glob 5182 if {$glob(enableautoupdate) != 0} { 5183 trace remove variable glob(enableautoupdate) write WakeListUpdater 5184 ListUpdater 5185 } 5186} 5187 5188proc ListUpdater {} { 5189 global glob config 5190 set did 0 5191 # set f [focus] 5192 # set class "" 5193 # if {$f != ""} { 5194 # set class [winfo class $f] 5195 # } 5196 if {$glob(enableautoupdate)} { # && $class != "Entry" 5197 LogStatusOnly "U" 5198 # Prevent re-entry, only one update at a time 5199 set glob(enableautoupdate) 0 5200 foreach inst {left right} { 5201 if { ! [IsVFS $glob(${inst},pwd)] } { 5202 set r [catch { set mtime [file mtime $glob($inst,pwd)] }] 5203 if {!$r} { 5204 if {$mtime != $glob($inst,lastmtime)} { 5205 #DoProtCmd "UpdateWindow $inst" 5206 # DoProtCmd "updateInPlace $inst" 5207 updateInPlace $inst 5208 set did 1 5209 #set glob($inst,lastmtime) $mtime #done in updatewindow 5210 } 5211 } 5212 } 5213 } 5214 set glob(enableautoupdate) 1 5215 5216 LogStatusOnly "." 5217 } else { 5218 trace remove variable glob(enableautoupdate) write WakeListUpdater 5219 trace add variable glob(enableautoupdate) write WakeListUpdater 5220 } 5221 if {$config(autoupdate)} { 5222 after cancel ListUpdater 5223 after [expr $config(autoupdate) * 1000] ListUpdater 5224 } 5225 return $did 5226} 5227 5228proc StartUpdaters {} { 5229 global glob config 5230 after 30000 TimeUpdater 5231 foreach lr {left right} { 5232 set glob($lr,lastmtime) 0 5233 set glob($lr,lasttime) 0 5234 set glob(inotify_after,$lr) {} 5235 } 5236 if {$config(autoupdate)} { 5237 # first update right away. 5238 after [expr $config(autoupdate) * 1000] ListUpdater 5239 } 5240} 5241 5242proc frgrab { w } { 5243 for {set i 0} {$i < 10} {incr i} { 5244 set r [catch {grab $w} out] 5245 if {!$r} { return } 5246 after 50 5247 } 5248 if {$r} { 5249 LogStatusOnly "$out" 5250 } 5251} 5252 5253proc CheckCmdLineArgs { } { 5254 # returns 1 if iconified by start up. Always 5255 # iconified, unless debuging... 5256 global argv glob 5257 set ops {} 5258 foreach db {db -db tkcon -tkcon -iconified early -early} { 5259 if {[set i [lsearch -exact $argv $db]] != -1} { 5260 set argv [concat [lrange $argv 0 [expr $i - 1]] \ 5261 [lrange $argv [expr $i + 1] end]] 5262 if {[string index $db 0] == "-"} { 5263 set ops [string replace $db 0 0] 5264 } 5265 lappend ops $db 5266 } 5267 } 5268 if {"early" in $ops} { 5269 startTkDebug $ops 5270 } else { 5271 set glob(debug) 0 5272 setupDebug 0 5273 wm withdraw . 5274 } 5275 return $ops 5276} 5277 5278proc startTkDebug {ops} { 5279 global glob 5280 set glob(debug) 0 5281 if {"db" in $ops} { 5282 set glob(debug) 1 5283 } 5284 setupDebug $glob(debug) 5285 expr {"tkcon" in $ops && [catch {package require tkconrc;tkcon show}]} 5286 #realWaitForIdle 5287} 5288 5289proc ViewBatchList {} { 5290 global glob 5291 set tmp [join $glob(batchlist) \n] 5292 ViewString {VFS Batch List} tmp 5293} 5294 5295 5296proc AddToBatchList { inst } { 5297 global glob 5298 foreach sel [$glob(listbox,$inst).file curselection] { 5299 set elem [lindex $glob($inst,filelist) $sel] 5300 lassign $elem {*}$glob(fListEl) 5301 switch $type { 5302 fl - 5303 fn { 5304 set item [list $glob($inst,pwd)/$file $size] 5305 lappend glob(batchlist) $item 5306 } 5307 default { 5308 PopError [_ "You can only add VFS files to the batch"] 5309 return 5310 } 5311 } 5312 } 5313} 5314 5315 5316proc CheckOwner { file } { 5317 if {! [file exists $file]} { 5318 return 1 5319 } 5320 return [file owned $file] 5321} 5322#trace add variable glob(select_cur_lr) write TraceIt 5323proc TraceIt { a b c } { 5324 global glob 5325 puts " $a element $b set to $glob($b)" 5326} 5327proc dumpStartTimes {} { 5328 # if {! $glob(debug)} {return} 5329 set frputsOn $::frputs::on 5330 setupDebug 1 5331 frputs "All times in milliseconds " 5332 frputs " Incr RunTotal " 5333 foreach ent $::startTimes { 5334 lassign $ent time mess 5335 if {![info exists st]} { 5336 set fr $time 5337 set st $time 5338 } 5339 frputs "[format {%5s %5s %s} [expr {$time - $st}] [expr {$time - $fr}] $mess] " 5340 set st $time 5341 } 5342 frputs "[expr {$time - $fr}] Total start time " 5343 setupDebug $frputsOn 5344 return $frputsOn 5345} 5346 5347# ------------------------------STARTUP------------------------------------ 5348# 5349##################################################################### 5350# This is the boiler plate code ver <20180124.1808.36> # 5351##################################################################### 5352# This first script (the command 'unload_tclIndex') and the # 5353# immediately following calls to it unload any files loaded by # 5354# references to env(TCLLIBPATH). This is done mostly to prevent # 5355# shipping an application that depends on local files, AND so # 5356# we/you get the right code when debugging. You may not care about # 5357# this or may depend on such in which case you should code a 0 in # 5358# the following if statement. # 5359# # 5360if {1} { ;# 5361 # This code will execute on loading/sourceing and should be in # 5362 # the main source of your code. The command 'unload_tclIndex', # 5363 # given the path to a tclIndex, attempts to source it, and, if # 5364 # successful removes all traces of any proc indexed in it unless # 5365 # it has already been called. This is why this code should be in # 5366 # the first script loaded and before any other code executed in # 5367 # that script. We assume that the caller has already removed it # 5368 # from "auto_path" # 5369 # # 5370 proc unload_tclIndex {dir} { ;# 5371 # The following test depends on un-documented variables in the # 5372 # Tcl source and as such is at risk. Good through Tcl 8.6.6 # 5373 # Caution: Tcl 8.6.6 moves auto_oldpath to ::tcl, but prior # 5374 # versions AND TclX have it as a global. If the given dir is # 5375 # not in auto_oldpath, it means this dirs index has not been # 5376 # sourced by the system yet, so we need do no more. # 5377 variable ::tcl::auto_oldpath ;# 5378 if {(![info exists auto_oldpath] || $dir ni $auto_oldpath) && 5379 (![info exist ::auto_oldpath] || $dir ni $::auto_oldpath)} { 5380 return ;# 5381 } ;# 5382 # # 5383 # The following 'source' command will create a local auto_index # 5384 # which we then use to look at the global auto_index. # 5385 # 5386 if {[catch {source [file join $dir tclIndex]}] != 0} {return} ;# 5387 foreach {name script} [array get auto_index] { ;# 5388 if {[info exists ::auto_index($name)] &&\ 5389 $::auto_index($name) == $script} { ;# 5390 unset ::auto_index($name) ;# 5391 # There is no way to know if this has been called already # 5392 # since it could be part of the core system. We MUST not # 5393 # rename it away. We know that a TCLLIBPATH set up a # 5394 # version, but NOT if the current program will set up its # 5395 # own. If it does not, a rename here would loose that # 5396 # functionality. # 5397 } ;# 5398 } ;# 5399 } ;# 5400 # This script removes any special local dirs from auto_path and # 5401 # calls the above to scrub any commands already loaded. # 5402 # # 5403 if {[info exists env(TCLLIBPATH)] } { ;# 5404 # We want to keep these even if in env(TCLLIBPATH) # 5405 set notThese [list $::tcl_library [file dir $::tcl_library]] ;# 5406 if {[info exists ::tcl_pkgPath]} { ;# 5407 lappend notThese {*}$::tcl_pkgPath ;# 5408 } ;# 5409 foreach path $env(TCLLIBPATH) { ;# 5410 if {$path in $notThese} {continue} ;# 5411 set indx [lsearch -exact $auto_path $path] ;# 5412 if {$indx != -1} { ;# 5413 set auto_path [lreplace $auto_path $indx $indx] ;# 5414 unload_tclIndex $path ;# 5415 } ;# 5416 } ;# 5417 } ;# 5418} ;# End of enabling if. # 5419# # 5420# This bit of code figures out where the rest of the routines are # 5421# on the assumption that they are in the same directory as the # 5422# initial code file. If 'setIt' is 1 or not coded auto_path is set # 5423# in any case the resulting dir is returned to the caller. If this # 5424# is in a 'freewrap' package, the windows leading C:/ (well really # 5425# <drive letter>:/) is removed as required by Wrap code for windows.# 5426# To function correctly this code MUST be called prior to completion# 5427# of the 'source' command that brings it in. Also, since it is used # 5428# to set up auto_path it can not be auto loaded. It may be sourced,# 5429# but again the from where issue is there. Therefor it is best if # 5430# this is just merger with the using code in a location prior to its# 5431# call. # 5432# # 5433proc cSetAutoPath {new} { ;# 5434 if {$new ni $::auto_path} {lappend ::auto_path $new} ;# 5435} ;# 5436# # 5437proc setAutoPath {{setIt 1}} { ;# 5438 set it [info script] ;# 5439 set it [expr {$it == "" ? "[pwd]/*" : $it}] ;# 5440 set it [file dir [file dir [file norm $it/*]]] ;# 5441 # Wrap code requires we not have the drive letter... # 5442 if {[namespace exists freewrap]} { ;# 5443 set it [regsub {^[a-zA-Z]:/} $it {/}] ;# 5444 } ;# 5445 if {$setIt} { ;# 5446 cSetAutoPath $it ;# 5447 } ;# 5448 return $it ;# 5449} ;# 5450##################################################################### 5451# End of boiler plate code # 5452##################################################################### 5453 5454proc doDeferedMessages {messages} { 5455 set rs {} 5456 foreach ms $messages { 5457 if {[set ms [string trim [regsub -all {\{|\}} $ms {}]]] != {}} { 5458 append rs $ms\n 5459 } 5460 } 5461 if {$rs != {}} { 5462 PopWarn $rs 5463 } 5464 # while {[llength $messages] > 1} { 5465 # set messages [lassign $messages mess] 5466 # if {[string trim $mess] != {}} { 5467 # PopInfo $mess 5468 # } 5469 # } 5470 # if {[set mess [lindex $messages 0]] != {}} { 5471 # smart_dialog .amess . {Message...} [list {} $mess] 0 0 {} 5472 # } 5473} 5474 5475 5476proc FindLibfr {} { 5477 global glob config env argv argv0 auto_path 5478 # clean up argv0 (it is used in Clone and possibly for run as root) 5479 set ::argv0 [file norm $::argv0] 5480 set tail [file tail [file dir [file norm [info script]/*]]] 5481 if {$tail == "" } { 5482 set tail [expr {$::tcl_platform(platform) == "windows" ? "fr.exe" : "fr"}] 5483 } 5484 set possible [pwd] 5485 5486 lappend possible [set lc [setAutoPath 0]] 5487 set success 0 5488 # puts "searching $possible for $tail from [info script] autopath returns $lc" 5489 foreach testfile [lreverse $possible] { 5490 # puts "testing $testfile" 5491 if { [file exists $testfile/$tail] == 1 } { 5492 lappend ::auto_path [set glob(lib_fr) $testfile] 5493 set success 1 5494 break 5495 } 5496 } 5497 if { $success != 1} { 5498 puts [_ "Can not find fr library. Looked in %s We quit!" \ 5499 $possible] 5500 exit 1 5501 } 5502 # just for grins... 5503 if {$lc != $testfile} { 5504 puts "Chose $testfile over $lc" 5505 } 5506 #set glob(catch) [glob -nocomplain $glob(lib_fr)/packages/*] 5507 5508 foreach path [list $glob(lib_fr)/packages\ 5509 [set glob(conf_dir) [file normalize [findFrDir]]]] { 5510 cSetAutoPath $path 5511 } 5512 5513 # From here on we can use all our normal error code. We may not 5514 # have all the color, but it will work... 5515 # The wm command here moves the following question to the center 5516 #(or there about) of the screen rather that having it get lost on an edge. 5517 wm geometry . +500+500 5518 # bring in the global config stuff 5519 if {[file readable $glob(lib_fr)/config]} { 5520 # puts "sourcing $glob(lib_fr)/config" 5521 set r [catch {source $glob(lib_fr)/config} out] 5522 if {$r} { 5523 PopInfo [_ "Reading system wide configuration from \ 5524 %s:\n%s" $glob(lib_fr)/config $out] 5525 } 5526 } 5527 if { ! [info exists glob(doclib_fr)] } { 5528 foreach fhf [list $glob(lib_fr) $glob(lib_fr)/doc] { 5529 #puts "Trying $fhf/HISTORY [file isfile $fhf/HISTORY]" 5530 if {[file isfile $fhf/HISTORY]} { 5531 set glob(doclib_fr) $fhf 5532 file lstat $fhf/HISTORY farry 5533 if {$farry(type) == "link"} { 5534 set glob(doclib_fr) \ 5535 [file dirname [file normalize [file readlink $fhf/HISTORY]]] 5536 } 5537 break 5538 } 5539 } 5540 if {! [info exists glob(doclib_fr)] } { 5541 lappend ::mess [_ "Can not find document directory. Looked here\n%s\n\ 5542 %s\ 5543 \nHelp menu items will not exist..." \ 5544 $glob(lib_fr) $glob(lib_fr)/doc] 5545 set glob(doclib_fr) {} 5546 } 5547 } else { 5548 if {![file readable $glob(doclib_fr)/HISTORY]} { 5549 lappend ::mess [_ "Document file %s is not readable \ 5550 \n(possibly does not exist)\ 5551 \nHelp menu \"Histroy\" will not exist" $glob(doclib_fr)/HISTORY] 5552 } 5553 } 5554} 5555# This allows re-sourceing of fr 5556if {[info exists glob(init_done)] && $glob(init_done)} { 5557 return 5558} 5559# What follows is (or should be) all initialization of globals 5560# followed by building the main window(s). 5561# Global package requirements... 5562# We require Tk for MS windows where we hope the package starts with 5563# tclsh and fr.tcl which sources this file (fr). It is important 5564# to have tclsh as that is how we get stdout pipes to work correctly. 5565 5566# This bit removes any special local dirs from auto_path. This is done mostly 5567# to prevent shipping a filerunner that depends on local files...And so we get 5568# the right code when debugging. MUST BE BEFORE FIRST PROC. 5569# if {[info exists env(TCLLIBPATH)] } { 5570# foreach path $env(TCLLIBPATH) { 5571# set indx [lsearch -exact $auto_path $path] 5572# if {$indx != -1} { 5573# set auto_path [lreplace $auto_path $indx $indx] 5574# # puts "removed $path from auto_path" 5575# } 5576# } 5577# # Now clear any auto_index entries added from TCLLIBPATH 5578# auto_reset 5579# } 5580 5581lappend startTimes [list [clock milliseconds] "Begin start up"] 5582set mess {} 5583package require Tk 5584package require msgcat 5585 5586lappend startTimes [list [clock milliseconds] "After Tk start up"] 5587 5588# not sure of what the 'subst' options should be (-nobackslashes or nil) 5589set stOps {} 5590# Here are a couple of UTF-8 characters that look like "/" and "\" 5591# but aren't. We use in places we want the look with out the effect. 5592set optionalSlash [format %c 0x0338] 5593set optionalBackSlash [format %c 0x2216] 5594# this list is used to find elements in the file lists 5595set glob(fListEl) [list sortval file type size mtime mode usergroup \ 5596 link nlink atime ctime] 5597 5598# command button labels are also use to find the command in this 5599# structure. We localize after we decide to use a button... 5600# 5601# The middle button sublist (one for each button) has the following entries; 5602# 0 The displayed name 5603# 1 The command to call 5604# 2 For keyboard mode, the key that invokes this command 5605# 3 For keyboard mode, the number of the character in the command to underline 5606# 4 The message to display for the command in "tips" or "ballon help" mode 5607# 5608set glob(cmds,list) { 5609 { {Copy} CmdCopy c 0 \ 5610 {[_b "Copy selected file(s) to other dir.\nif\ 5611 the selected file is a dir, recursively\ncopies\ 5612 all files in the tree under that dir." ] }} 5613 { {CopyAs} CmdCopyAs "" 0 \ 5614 {[_b "Copy selected file(s) to other dir with new name." ]} } 5615 { {Delete} CmdDelete d 0 {[_b "Delete selected file(s)" ]} } 5616 { {Move} CmdMove m 0 {[_b "Move selected file(s) to other dir." ]} } 5617 { {MoveAs} CmdMoveAs "" 0 { 5618 [_b "Move selected file(s), to other dir with new name(s)."]}} 5619 { {Rename} CmdRename r 0 \ 5620 {[_b "Rename selected file(s).\nCan cause move." ]} } 5621 { {MkDir} CmdMakeDir "" 0 \ 5622 {[_b "Create new dir from modified dir line.\nIf\ 5623 no modified dir line, prompts with\nleft dir as starter." ]} } 5624 { {S-Link} CmdSoftLink s 0 {[_b "Create a symbolic link\ 5625 to\nselected file(s) in other dir." ]} } 5626 { {S-LnAs} CmdSoftLinkAs "" 0 {[_b "Create a symbolic link to\ 5627 selected\nfile(s) in other dir.\ 5628 prompting for a\nnew name for each file." ]} } 5629 { {Chmod} CmdChmod h 1 \ 5630 {[_b "Change the mode flags for selected file(s)." ]} } 5631 { {View} CmdView v 0 \ 5632 {[_b "For dirs, go to the selected dir,\nfor\ 5633 files, execute the %s rule selected\nprogram\ 5634 with the selected file." "View"]} } 5635 {{ViewAsTx} CmdViewAsText "" 0 \ 5636 {[_b "Sends selected files directly to a View\n\ 5637 window regardless of file type or extension."]} } 5638 { {Open} CmdOpen o 0 \ 5639 {[_b "For dirs, go to the selected dir,\nfor\ 5640 files, execute the %s rule selected\nprogram\ 5641 with the selected file." "Open"]} } 5642 { {Run} CmdRunCmd "" 0 \ 5643 {[_b "Run a program passing the selected file(s)."]} } 5644 { {Edit} CmdEdit e 0 \ 5645 {[_b "Pass the selected file(s) to\nthe\ 5646 user definded editor." ]} } 5647 { {Q-Edit} CmdQEdit q 0 \ 5648 {[_b "Pass the selected file(s) to\nthe\ 5649 internal (tcl) editor." ]} } 5650 { {Arc} CmdArc a 0 \ 5651 {[_b "Pass the selected file to the\n rule\ 5652 defined archive program." ]} } 5653 { {UnArc} CmdUnArc u 0 \ 5654 {[_b "Pass the selected file to the\n rule\ 5655 defined unarchive program." ]} } 5656 { {UnPack} CmdUnPack p 2 \ 5657 {[_b "Pass the selected file to the rule\ndefined\ 5658 unpack/uncompress program." ]} } 5659 { {ForEach} CmdForEach "" 0 \ 5660 {[_b "Run a selected (prompted for)\nprogram on\ 5661 selected file(s)." ]} } 5662 { {Print} CmdPrint "" 0 \ 5663 {[_b "Pass the selected files to the\nuser\ 5664 defined print program." ]} } 5665 { {Diff} CmdDiff f 2 \ 5666 {[_b "Pass the last two selected files or\ndirs\ 5667 (may both be in the same dir) to\nthe user\ 5668 defined diff program." ]} } 5669 {{Rsync copy} CmdRsync "" 0 \ 5670 {[_b "Rsync copies files as does copy but if one\ 5671 \ndirectory is not local (nfs cifs or vfs)\ 5672 \nrsync will be called with the host address such\ 5673 \nthat the transfer is using rsync's private connection\ 5674 \nto the remote host." ]}} 5675 { {Select} CmdSelect "" 0 \ 5676 {[_b "After you enter a pattern\n in\ 5677 one of the dir lines,\n selects\ 5678 all matching files." ]} } 5679 { {HardLink} CmdHardlnk h 0 \ 5680 {[_b "Creates hard links in the opposite dir\n of\ 5681 selected files. If the selection is a\n dir\ 5682 recursively desends the dir creating hard\n links\ 5683 for each file. Uses a user selected program." ]}} 5684 { {HardLinkAs} CmdHardlnkAs "" 0 \ 5685 {[_b "Creates hard links, with a new name, in the opposite dir\n of\ 5686 selected files. If the selection is a\n dir\ 5687 recursively desends the dir creating hard\n links\ 5688 for each file. Uses a user selected program." ]}} 5689 { {Mount VFS} CmdMount "" 0 \ 5690 {[_b "Mounts the selected file as a virtual file\ 5691 \n system (VFS)."]} } 5692 { {UMount VFS} CmdUMount "" 0 \ 5693 {[_b "Un Mounts the selected file as a virtual file\ 5694 \n system (VFS)."]} } 5695} 5696 5697# We want the doProt family to be re-entrant so we don't lose the cursor/ 5698# update status... 5699# 5700set DoProtLevel 0 5701set MaxDoProtLevel 0 5702set DoProtProc {} 5703 5704set DNlist {} 5705 5706set glob(asyncCount) 0 5707set glob(mbutton) 0 5708set glob(start_path) [pwd] 5709set glob(ftp,debug) 0 5710set glob(userMenuList) {} 5711#puts "about to do cmdline args" 5712FindLibfr 5713set startOps [CheckCmdLineArgs] 5714lappend startTimes [list [clock milliseconds] "After cmd line args"] 5715#puts "icon is $icon" 5716source $glob(lib_fr)/frVersion.tcl 5717regsub {20([0-9][0-9])([0-9][0-9])([0-9][0-9])\.([0-9][0-9]).+} \ 5718 $glob(version) {\1.\2.\3.\4} glob(Sversion) 5719set glob(displayVersion) $glob(Sversion)[expr {[namespace exists freewrap] ? "w" : ""}] 5720lappend startTimes [list [clock milliseconds] "After finding libary"] 5721set Copyright [format "Copyright: 5722� 2010-%s Tom Turkey 5723� 1996-1999 Henrik Harmsen" [string range $glob(version) 0 3]] 5724 5725# setupDebug $glob(debug) 5726lappend startTimes [list [clock milliseconds] "After debug setup"] 5727 5728#puts "about to do set platform" 5729 5730set glob(notify,Available) 0 5731 5732 5733 5734set glob(inotify_flags) {} 5735 5736#puts "set up inotify" 5737set glob(cygwin) {} 5738if {[namespace exists freewrap]} { 5739 source $glob(lib_fr)/packageLinks.tcl 5740} 5741 5742CheckConfigDir 5743lappend startTimes [list [clock milliseconds] "After check config dir"] 5744 5745################################### Load platform code ####################### 5746package require $tcl_platform(platform) 5747 5748set glob(notify,left) [set glob(notify,right) ""] 5749set glob(init_done) 0 5750 5751#puts "about to do home" 5752 5753lappend startTimes [list [clock milliseconds] "After platform setup"] 5754 5755# Now the user commands and config stuff 5756 5757set config(usercommands) "" 5758if { [file exists $glob(conf_dir)/cmds ] } { 5759 set r [catch { source $glob(conf_dir)/cmds } out] 5760 if { $r != 0 } { 5761 lappend ::mess\ 5762 [_ "Error loading code from %s/cmds:\n\n%s" $glob(conf_dir) $out] 5763 # Lets treat this as non-fatal... 5764 } 5765} 5766lappend startTimes [list [clock milliseconds] "After user commands setup"] 5767 5768set glob(left,listhead) "" 5769set glob(right,listhead) "" 5770set glob(panelsLocked) 1 5771set glob(selected) left 5772set glob(localCmds) [list cd history view type] 5773lappend startTimes [list [clock milliseconds] "After fast check box setup"] 5774::VFSvars::VFS_InvalidateCache 5775InitConfig 5776buildTbarIcon 5777# lh [array get glob gui*] 5778lappend startTimes [list [clock milliseconds] "After init config setup"] 5779namespace eval ::autoscroll {proc autoscroll {args} {}} 5780set pak [catch { 5781 package require autoscroll 5782 package require cursor 5783 ::cursor::propagate . {} 5784}] 5785ShowWindow 5786lappend startTimes [list [clock milliseconds] "After main window build"] 5787expr {"iconified" ni $startOps && [wm deiconify .] == {} && [wm att . -al 0.0] == {}} 5788lappend ::startTimes [list [clock milliseconds] "After main window deiconify"] 5789# initialize the password locker (moved to config.tcl) 5790# ::pwLocker::init ::config(passwordLocker) \ 5791# [list encrypt $env(USER)] \ 5792# [list decrypt $env(USER)] \ 5793# [list SaveConfig] 5794 5795frputs config(passwordLocker) 5796lappend mess [ReadConfig] 5797lappend startTimes [list [clock milliseconds] \ 5798 "After complete read config setup\ 5799 [winfo viewable .fupper.fright.frame_listb.top.c.file]"] 5800ConfigPwd 5801lappend startTimes [list [clock milliseconds] \ 5802 "After config pwd [winfo viewable .fupper.fright.frame_listb.top.c.file]"] 5803# Wait for the window to materialize 5804while {![winfo viewable .fupper.fright.frame_listb.top.c.file]} { 5805 lappend ::startTimes [list [clock milliseconds] "main not viewable"] 5806 frputs "[realWaitForIdle] " 5807} 5808lappend ::startTimes [list [clock milliseconds] "After main viewable "] 5809StartUpdaters 5810lappend startTimes [list [clock milliseconds] "After updaters started"] 5811if {$::tcl_platform(os) == "Linux"} { 5812} 5813set sr [ShowRev] 5814realWaitForIdle 5815Try {setUpInotify} -a 5816if {!$::MSW && !$config(manualMonitors)} { 5817 Try {::displays::init} -a 5818} 5819if {$sr && [file exist $glob(doclib_fr)/HISTORY]} { 5820 ViewText $glob(doclib_fr)/HISTORY 5821} 5822 5823after 0 cleanTmpFiles 5824after 0 setBalloon 5825# Check if we have a decent kill function... 5826set r [killInit] 5827if {$r != 0 } { 5828 if {$r == {}} { 5829 set notice "Because a \"kill\" function was not found a program has 5830been set up to do the \"kills\". The \"kill\" function is available in 5831the Tclx package which you may want to install. Because this file now 5832exists in your \".fr\" directory, you will not see this message again." 5833 } else { 5834 set notice "Because a \"kill\" function was not found an attempt to set 5835up a program to replace this functionality. None of the following 5836acceptable programs were found: \n[split $r \n] 5837This means the stop button will not work. Please attempt to install either 5838the tcl package Tclx \(which implements a kill funtion\) or one of 5839these programs to fixthis problem. Because this file now 5840exists in your \".fr\" directory, you will not see this message again." 5841 } 5842 if {![file exists $glob(conf_dir)/killNotice.txt]} { 5843 PopInfo $notice 5844 set r [catch {open $glob(conf_dir)/killNotice.txt w} fid] 5845 if {$r != 0} { 5846 PopInfo "Error opening $glob(conf_dir)/killNotice.txt: $fid" 5847 } else { 5848 puts $fid $notice 5849 close $fid 5850 } 5851 } 5852} 5853 5854 5855CmdMountOnStart 5856# dumpStartTimes 5857startTkDebug $startOps 5858unset startOps 5859set glob(init_done) 1 5860Log [_ "Welcome to FileRunner v%s.\ 5861 %s" $glob(displayVersion) $Copyright] 5862lappend startTimes [list [clock milliseconds] "After welcome"] 5863 5864set glob(program) [info script] 5865doDeferedMessages $mess 5866 5867# if {$mess != {}} { 5868# smart_dialog .amess . {Message...} [list {} $mess] 0 0 {} 5869# } 5870return 5871