#!/bin/sh # #Tkdiff has two extraneous scrollbars, to which I find little use since #there is a middle scrollbar. As such, I have modified its source code to #get rid of them. Enjoy. Version 5-1. #Obtained from . # #-*-tcl-*- # the next line restarts using wish \ exec wish "$0" -- ${1+"$@"} ############################################################################### # # TkDiff -- A graphical front-end to diff for Unix and Windows. # Copyright (C) 1994-1998 by John M. Klassa. # Copyright (C) 1999-2001 by AccuRev Inc. # Copyright (C) 2002-2005 by John M. Klassa. # # TkDiff Home Page: http://tkdiff.sourceforge.net # # Usage: see "tkdiff -h" or "tkdiff --help" # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ############################################################################### # Chgd from 8.0 to 8.5 as of V4.3 to ensure support of "Text displaylines" package require Tk 8.5 # set a couple o' globals that we might need sooner than later set g(name) "TkDiff" set g(version) "5.1" set g(debug) 0 ;# Initialized (by default) to false # get this out of the way -- we want to draw the whole user interface # behind the scenes, then pop up in all of its well-laid-out glory wm withdraw . ############################################################################### # Primitive Debugging output (ie. useful values, states, etc.) during operation # Semi-cryptic output, but helpfull (assuming pgmr planted it in useful places) # can be enabled by: global var, cmdline flag or hard-coded per instance ############################################################################### proc Dbg {message {force 0} {where stderr}} { global g if {$g(debug) || $force} { puts $where "Dbg: $message" } } # Startup phases: # IMPORTANT: this is a PRIMARY mechanism by which we act to prevent TK from # performing 'callbacks' or other actions at in-opportune times. # In short: level-0 begins at script readin. Level-1 should be set when # major data upheavals (wipes/builds) are about to take place. # Moreover, callbacks themselves should try to separate WATCHING # what TK wants to do, from actually ALLOWING TK to initiate such # actions by only allowing any data dependent portions once level # 2 is current. # This then makes it possible for the application-side to invoke AT WILL # when IT knows the data is ready - **even** when level 2 has not quite # (as yet) officially been achieved! (See 'map-resize' as a key example). # HOWEVER, because it IS a 'global' flag, it cant be raised until ALL it # expects to cover is ready. If there is a need for finer 'granularity' # we can always invent more "Phases", designating which is needed by whom. # # 0 : Bare metal, looking for viable cmd args, obtaining 1st SCM content # 1 : Transitioning to GUI mode and/or DURING major datastruct upheavals # 2 : Operational mode set g(startPhase) 0 # FIXME - move to preferences option add "*TearOff" false 100 option add "*BorderWidth" 1 100 # Determine the windowing system # (since there are different ways to do this per past versions of tcl) if {[catch {tk windowingsystem} w(wSys)]} { # (older versions derive windowingSystem from the platform) if {"$::tcl_platform(platform)" == "windows"} { set w(wSys) "win32" } elseif {"$::tcl_platform(platform)" == "unix"} { set w(wSys) "x11" } elseif {"$::tcl_platform(platform)" == "macintosh"} { set w(wSys) "classic" } else { set w(wSys) "x11" # Note: this is NOT Darwin (ie. MacOS X) -> Aqua as # 'tk windowingsystem' CANT have 'catch'ed to ARRIVE here } } # Determine the name of the temporary directory, # and the name of the rc file, both of which are platform dependent. # This WILL be overridden by a preference in .tkdiffrc, # EXCEPT (obviously) when no such file actually exists yet switch -- $::tcl_platform(platform) { windows { if {[info exists ::env(TEMP)]} { set opts(tmpdir) [file nativename $::env(TEMP)] } else { set opts(tmpdir) C:/temp } set basercfile "_tkdiff.rc" # Native look for toolbar set opts(fancyButtons) 1 set opts(relief) flat } default { if {[info exists ::env(TMPDIR)] && $w(wSys) != "aqua"} { # MacOS X sets TMPDIR to something awful like # /var/folders/uC/uCFr1z6qESSEYkTuOsevX++++yw/-Tmp-/ # don't let it AFFECT (infect?) us set opts(tmpdir) $::env(TMPDIR) } {set opts(tmpdir) /tmp } set basercfile ".tkdiffrc" # Native look for toolbar set opts(fancyButtons) 0 set opts(relief) raised } } # Compute preferences file location. Note that TKDIFFRC can hold either # a directory or a file, though we document it as being a file name if {[info exists ::env(TKDIFFRC)]} { set rcfile $::env(TKDIFFRC) if {[file isdirectory $rcfile]} { set rcfile [file join $rcfile $basercfile] } } elseif {[info exists ::env(HOME)]} { set rcfile [file join $::env(HOME) $basercfile] } else { set rcfile [file join "/" $basercfile] } # Where should we start? MacOSX apps want to start in / which is obnoxious if {[pwd] == "/"} { if {[info exists ::env(HOME)]} { catch {cd $::env(HOME)} } } # Try to find a pleasing native look for each platform. # Fonts. set sysfont [font actual system] #Dbg "system font: $sysfont" 1 # See what the native menu font is . configure -menu .native menu .native set menufont [lindex [.native configure -font] 3] destroy .native # Find out what the tk default is label .testlbl -text "LABEL" set w(background) [lindex [.testlbl cget -background] 0] set w(foreground) [lindex [.testlbl cget -foreground] 0] set labelfont [lindex [.testlbl configure -font] 3] destroy .testlbl text .testtext set textfont [lindex [.testtext configure -font] 3] destroy .testtext entry .testent set w(selcolor) [lindex [.testent configure -selectbackground] 4] set entryfont [lindex [.testent configure -font] 3] destroy .testent #Dbg "menufont $menufont" 1 #Dbg "labelfont $labelfont" 1 #Dbg "entryfont $entryfont" 1 #Dbg "textfont $textfont" 1 set fs [lindex $textfont 1] if {$fs == ""} { # This happens on Windows in tk8.5 (and apparently *nix too)! # You get {TkDefaultFont} instead of {fixed 12} or whatever # Then when you add "bold" to it, WHAM - you have a bad spec! # Lets decompose it, to RE-compose it: lassign [font actual $textfont] na fm na fs set textfont [list $fm $fs] } #Dbg "textfont $textfont" 1 set font [list $textfont] set bold [list [concat $textfont bold]] #Dbg "::font($font)\n::bold($bold)" 1 option add *Label.font $labelfont userDefault option add *Button.font $labelfont userDefault option add *Menu.font $menufont userDefault option add *Entry.font $entryfont userDefault # This makes tk_messageBox use our font. # The default tends to be terrible no matter what platform option add *Dialog.msg.font $labelfont userDefault # Initialize arrays ####################### # general globals # Note: MORE keynames exist than just those shown here (eg. name, debug, ...) # Note: 'scmS' is the STATIC list of ALL known SCMs (rvrs alpha sorted). # Note: 'scmSrch' is a STATIC list of SCMs capable of searches array set g { conflictset 0 bLnum 0 destroy "" d3Left {} d3Right {} ignore_hevent,1 0 ignore_hevent,2 0 is3way 0 lnumDigits 4 mapborder 0 mapheight 0 mapwidth 0 mapScrolling 0 mergefile "" mergefileset 0 returnValue 0 scmDOsrch 0 scmPrefer "" scmS {SVN SCCS RCS PVCS Perforce HG GIT CVS ClearCase BK Accurev} scmSrch {CVS GIT SVN} showmerge 0 statusCurrent "Standby...." statusInfo "" tempfiles "" thumbMinHeight 10 thumbDeltaY 0 } set UniQ 0 ;# Generic counter for ensuring UNIQUE object names # reporting options array set report { doSideLeft 0 doLnumsLeft 1 doCMrksLeft 1 doTextLeft "Full Text" doSideRight 1 doLnumsRight 1 doCMrksRight 1 doTextRight "Full Text" filename "tkdiff.out" fnamVetted 0 BMrptgen {} } # Be advised (regarding the following global array definition): # Produces On-demand Asynchronous file input via 'exec' machinery # (EXISTANCE of the element 'trigger' WILL activate it) array set ASYNc { out "" events 0 } # Only those elements that are gauranteed to exist are initialized here. # The remainder of the FINFO entries are dynamically added and (occasionally # removed) as the user interacts with the tool. There are 3 categories of # information: # #1. entries that describe INPUT parameters: # f,* filespec that describe files/dirs/URLs to be acted upon # rev,* revision value (for a to-be-detected SCM system) # scm* SCM list (DERIVED from 'f,*'), that detected as valid # ulbl,* user-label: when provided, overrides "lbl" (see below) # # #2. entries ACTUALLY used AFTER input has been processed # pth,* the actual local (possibly temp) file to compare # tmp,* optional flag denotes "pth" AS a tempfile (& other uses) # lbl,* displayable label for "pth" # pproc,* special post processing needed for "pth" (rare) # # #3. entries VERY similar to #2, but pertaining to ANCESTOR files # apth,* the actual local (possibly temp) file to compare # atmp,* optional flag denotes "apth" AS a tempfile (& other uses) # albl,* displayable label for "apth" # # In each above case, '*' is a monotonic number beginning at 1. Zero # is a special case used exclusively for a #1 "Ancestor File" entry. # The SAME value, WITHIN its category, describes attributes of a SINGLE # object --- However "ulbl" is an exception - its number is USED by # category 2, despite being SET by category 1 (reasons are mostly # historical, dating from a time when the only values WERE 1 & 2); # "ulbl" is NOT expected to see usage beyond that still valid case, # although it is NOT specifically prohibitted. # # Items in category #1 represent data ENTERRED by the user; as such they # are tied somewhat to the GUI (thereby initialized here), and are # (mostly) fixed at being at MOST two each (except MAYBE ulbl). Note that # scm,* (as an entry) is mostly for the inquiry/search modes as individually # retrieved files will generate their OWN (NOT modifying this global value). # # Items in category #2 (NOT set here) are grouped as adjacently numbered # PAIRS, and are files intended, actually, or previously been compared, # DERIVED from the items of category #1. # # Items in category #3 (NOT set here) use a DISJOINT monotonic numbering # system from 1 to "fPairs" (explained next) AND a 'a'-prefix naming # # "fCurpair" designates which monotonic PAIR is actively in use (1->fPairs) # with "fPairs" itself being the COUNT of how many "fCurpair"s exist. # # Thus "f,1" DIRECTLY implying "pth,1" is true ONLY if "f,1" designates a # single file. Likewise for "f,2" -> "pth,2". Input fields designating # directories and/or SCM branches (or commits) can generate SEVERAL "pth,N" # (and other category 2) entries, each. # # The "lbl,Left" and "lbl,Right" and "title" entries are simply the DISPLAYED # label values (set from whatever the ACTIVE pair of "lbl,*" entries are), # and are tied directly to the GUI, (providing a cheap update mechanism). # # IMPORTANT: # Certain COMBINATIONS of category 2/3 entries (existance, emptiness) are used # to describe various situations (i.e. tmp files, real files, pairs needing # comparison but NOT yet fully extracted from a necessary SCM repository; # or files NOT editable because they were extracted by an SCM; and even when # a 3way diff is to be considered active: EXISTANCE of 'albl,N' element). # EXERCISE CARE Re: ADDING/RENAMING of NEW elements... # Category 2/3 values are essentially considered TRANSIENT and MAY BE # DELETED or reset at times using patterns such as '[aptl]*[0-9]'. # # Be VERY CAUTIOUS when considering CHANGING ANY of these manipulations! array set finfo { title {} fPairs 0 fCurpair 1 lbl,Left "label_of_file_1" lbl,Right "label_of_file_2" f,0 "" rev,0 "" f,1 "" ulbl,1 "" rev,1 "" scm1 "" f,2 "" ulbl,2 "" rev,2 "" scm2 "" } # IMPORTANT: # Color makes a HUGE difference to Tkdiff - lack of it, well, is gonna be # REALLY BAD with MANY features virtually UN-USABLE ... BUT it COULD "run". # # Historical notes: ################## # From V4.2 thru V5.0 a truely DISMAL ability to run MONOCHROME was maintained. # AS OF V5.1 (circa 2020) we decided that you likely cant BUY a B+W monitor # anymore, and even if you did, its HIGHLY unlikely you'd be using THIS tool. ################## # While we have left inplace the STRUCTURE to PROVIDE such support, AND the # critical CONTENT for re-engineering the changes to RESTORE that capability, # # POOF - Its now GONE!! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< # # Notably, the "else" to this test for color support WOULD NEED to contain lots # of local vars, suitably sprinkled throughout the 'driving list' for SETTING # the defaults. IN ADDITION, to the extent that they would CONFLICT with how # the COLOR settings are described, those SAME LOCAL VARS would require setting # within the "if-color" branch (not unlike how the colors themselves are done). # After, those locals, having replaced the hardcoding, SHOULD be UNSET as well # #################################### # # BECAUSE of all that, TkDiff **WILL NOW ABORT** if color is unavailable !! # # Yet THAT eventuality necessitates some juggling of "procs" to ensure they # EXIST before someone calls them. SO we need them HERE, NOW, because the # setting of APPLICATION DEFAULTS is taking place at script "READ-IN time"! # # Furthermore, because these will ALL now reside ABOVE the demarcation of our # builtin pgm-flow tracing "region" they will ALWAYS operate silently untracked # REGARDLESS of WHEN they may be invoked (be that now to ABORT, or later on). # Needed is: 'fatal-error' and 'do-exit' # Conveniently, BEYOND those two, FURTHER calls will NOT EMMANATE either # because the needed conditions WILL NOT be met, OR they are protected by # 'catch'-stmts for their OWN internal reasons (ie. NOT because of this) # ############################################################################# ############################################################################### ############################################################################### ## Severe Error/Exit handling mechanisms ############################################################################### ############################################################################### # Throw up a modal error dialog or print a message to stderr. # In general we print to stderr and exit if the main window hasn't yet been # created, otherwise put up a dialog and throw an exception. ############################################################################### proc fatal-error {msg} { global g if {$g(startPhase)} { popmsg $msg "Aborting..." } else { puts stderr "Error: $msg\n$g(name) Aborted" } do-exit 2 } ############################################################################### # Exit with proper code ############################################################################### proc do-exit {{returncode {}}} { global g w ASYNc # During pgm startup, we MAY have built the status window just to let the # user know we are talking to a SCM server that MIGHT experience network # latency - so if that window exists (but OTHER windows do not) and we are # here, something died and we want to RELEASE that window before we leave. if {[info exists w(status)] && ![info exists w(client)]} { Dbg "something died (or was killed) ... trying to shutdown" catch {wm forget $w(status)} # Release any extra event loop (if it is running) so we CAN leave set ASYNc(events) 0 unset -nocomplain ASYNc(trigger) ;# not much point, but it IS correct } # we don't particularly care if del-tmp fails. catch {del-tmp} if {$returncode == {}} { set returncode $g(returnValue) ;# Value from latest external execution } # exit with an appropriate return value exit $returncode } ############################################################################### # OK - FINALLY we can establish the DEFAULTS for running TkDiff (@ READ-IN !) ############################################################################### if {[string first "color" [winfo visual .]] >= 0} { # We have color - HURRAY!! (but, let's not go crazy...) # # This mass assignment is a NOD to the days of monochrome support # It remains more as an example of how to approach reinstating such, and is # NOT absolutely needed as the colors could simply be PLANTED where they go lassign "Tomato PaleGreen DodgerBlue yellow magenta \ Goldenrod1 Khaki gray LightSteelBlue blue" \ Pdel Pins Pchm Polp Padj Pinf Pcur Pdif Pcht Pbyt # (closebrace) else (openbrace) <-- WOW Tcl is real pissy about braces!! # # Only black and white?? YUCK (It's gonna look/work AWFUL, sorry). # lassign {Black White} bLk wHt ;# <-- just shortening the color names # lassign "$bLk $bLk $bLk $bLk $bLk $wHt $bLk $wHt $bLk $bLk" \ # Pdel Pins Pchm Polp Padj Pinf Pcur Pdif Pcht Pbyt # # These were the specifics of the MONOCHROME support settings: # # textopt "-background white -foreground black -font $font" # currtag "-background $Pcur -foreground white" # difftag "-background $Pdif -foreground black -font $bold" # deltag "-background $Pdel -foreground white" # instag "-background $Pins -foreground white" # chgtag "-background $Pcht -foreground white" # overlaptag "-background $Polp -foreground white" # bytetag "-underline 1" # inlinetag "-underline 1" # mapins "$Pins" # mapdel "$Pdel" # mapchg "$Pchm" # adjcdr "$Padj" # inform "$Pinf" # # The PROBLEM is that 'font'ing, underlining, etc were used to compensate # for the LACK of colors in certain instances posing complex substitution # situations (different option counts) together, PLUS more INVERSE VIDEO use # } else { fatal-error "$g(name) no longer supports Monochrome operation" } # Establish the DEFAULT option values for numerous application-wide items ... # (most are generally customized at runtime and become USER preferences) # # Each item is designated by an internal KEY and ALWAYS has a VALUE in 'opts()' # AND (if a DESCRIPTION was provided) thats kept (via the SAME key) in 'pref()' # Thus 'opts()' ALWAYS exists, but only MOST are considered as User PREFERENCES # (N.B> During ongoing development simply ADD to the table CONTENT as needed, # ( -> do NOT ALTER keys unless remapping OLD ones during UserPref READS) # ( > SOME 'opts' have ALREADY been Pre-defaulted: just PRESERVE them here) # *** IMPORTANT *** # Keys matching "[mng][rae][gvn]*" are CARGO Capable (ie $w(wSys) dependant)! # The 'Key-' descriptor MUSTN'T be specified as a default: (Aqua will barf!) foreach {key val desc} [subst { adjcdr "$Padj" {CDR region color during adjustment} autocenter 1 {Automatically center current diff region } autoselect 0 {Auto-select nearest diff region when scrolling} autoSrch 0 {Auto-search detected SCM when capable} bytetag "-background $Pbyt -foreground white -underline 1" {Tag options for characters in line view} chgtag "-background $Pcht" {Tag options for changed diff region} colorcbs 0 {Color change bars to match the diff map} currtag "-background $Pcur" {Tag options for the current diff region} customCode {} {} deltag "-background $Pdel -font $bold" {Tag options for deleted diff region} diffcmd "diff" {diff command} difftag "-background $Pdif" {Tag options for diff regions} editor "" {Program for editing files} fancyButtons $opts(fancyButtons) {Windows-style toolbar buttons} filetypes { {"Text Files" {*.txt *.tcl}} {"All Files" {*}} } {Choice of file suffixes for file dialogs} geometry "80x30" {Text window size} genEdit "" {Invoke an editor on the Current file} genFind "" {Request textual search in either file} genNxfile "" {Switch to next available file} genPvfile "" {Switch to prev available file} genRecalc "" {Request to re-diff current file pair} genXit "" {Request Immediate tool exit} ignoreblanks 0 {Ignore blanks when diffing} ignoreblanksopt "-b" {Options for Ignoring blanks} ignoreEmptyLn 0 {Suppress diffs of empty lines} ignoreRegexLnopt {} {RegExp(s) for matching lines} ignoreRegexLn 0 {Suppress diffs of RegExp-matched lines} inform "$Pinf" {Informational highlight: Tooltips + bindings} inlinetag "-background $Pcht -font $bold" {Tag options for diff region inline differences} instag "-background $Pins -font $bold" {Tag options for inserted diff region} mapchg "$Pchm" {Map color for changes} mapdel "$Pdel" {Map color for deletions} mapins "$Pins" {Map color for additions} mapolp "$Polp" {Map color for collisions} mrgLeft "" {Mark CDR for Leftside Merge} mrgLtoR "" {Mark CDR for Left-then-Right Merge} mrgRght "" {Mark CDR for Rightside Merge} mrgRtoL "" {Mark CDR for Right-then-Left Merge} navCntr "" {Center CDR within Display window} navFrst "" {Move CDR to First Diff region} navLast "" {Move CDR to Last Diff region} navNext "" {Move CDR to Next Diff region} navPrev "

" {Move CDR to Previous Diff region} overlaptag "-background $Polp" {Tag options for overlap diff region} predomMrg 1 {Predominate merge choice} scmPrefer {Auto Auto} {Prefer given SCM when detected} showcbs 1 {Show change bars} showinline1 0 {Show inline diffs (per-byte method)} showinline2 1 {Show inline diffs (recursive method)} showlineview 0 {Show current line comparison window} showln 1 {Show line numbers} showmap 1 {Show graphical map of diffs} syncscroll 1 {Synchronize scrollbars} tabstops 8 {Tab stops} tagcbs 0 {Highlight change bars} tagln 0 {Highlight line numbers} tagtext 1 {Highlight file contents} textopt "-background white -foreground black -font $font" {Text widget options} tmpdir $opts(tmpdir) {Directory for scratch files} toolbarIcons 1 {Use icons instead of labels in the toolbar} }] { set opts($key) $val ; if {$desc != {}} {set pref($key) $desc} } # So much for defaulting ... (as mentioned earlier) "BRIEFLY" is now over! # Whack the little vars we used to make adjustments to the option values unset Pdel Pins Pchm Polp Padj Pinf Pcur Pdif Pcht Pbyt # Further ensure wrapping is turned off. This might piss off a few people, # but it would screw up the display ROYALLY to have things wrap set opts(textopt) "$opts(textopt) -wrap none" # NOW go OVERWRITE all those defaults (by READING the USERS Preferences file) # Any errors will be reported. But before doing so, we need to CREATE: proc define {name value} { global w opts # Any key coming thru that CONTAINS (read as: PREFIXED) with the value of # the CURRENT windowing system must be stripped back to its REAL preference # name (and stored as such). This allows anything else (such as some OTHER # PLATFORMs setting - aka bindings) to just simply be retained (as CARGO) # N.B> Requires NON-'prefix' use of cargo TRIGGER strings to be Verboten! set opts([string map "$w(wSys) {}" $name]) $value } # which lets the rc file have a slightly more human-friendly interface, AND # hides our 'cargo' mechanism for w(wSys) DEPENDANT values! # Old-style .rc files should still load just fine for now, though it ought to # be noted new .rc files won't be able to be processed by older TkDiff vrsns # BUT - that SHOULDN'T be a problem. if {[file exists $rcfile]} { if {[catch {source $rcfile} error]} { set startupError [join [list "There was an error in processing your\ startup file." "\n$g(name) will still run, but some of your\ preferences" "\nmay not be in effect." "\n\nFile: $rcfile" \ "\nError: $error"] " "] } } # Hack to handle older (~ V2.xx+) preferences files... # If user had a diffopt defined in their rc file, # we'll magically convert that to diffcmd... if {[info exists opts(diffopt)]} { lappend opts(diffcmd) "$opts(diffopt)" unset opts(diffopt) } # Work-around for bad font approximations, # as suggested by Don Libes (libes@nist.gov). catch {tk scaling [expr {100.0 / 72}]} ############################################################################### # Our Dialog 'factory' supporting: creation/display/invocation/release # Specific actions/args are per each subcmd & existence of 'windowName' (wNM) ########################## # NONMODAL # MODAL wNM ?toplevel-args? # Create/restores Dialog window toplevel; RCode indicates which. # 1= wNM existed and will be reused; 0= wNM was JUST NOW created: # caller then DEFINEs content (if reqd), followed by any needed # cfg/re-cfg, ultimately terminated with a PROPER 'show' subcmd # NONMODAL .vs. MODAL are mutually exclusive subcmds establishing # the mode (and expected usage) EACH performing the same tasks. # N.B> CHOICE of mode affects HOW to construct AND show the window!! # dismiss wNM ?savepos? # Remove dialog from display. Optionally (savepos==true) retain # last known size/position of window to reinstate on next use # Default savepos=0. NOTE: 'savepos' is generally only needed # if the dialog was intended to be DESTROYED and then rebuilt. # A simple 'dismiss' WILL tend to RE-display at its PRIOR loc. # # # # # # # # The following subcmd causes the dialog to be displayed and is designed to # be used after POSSIBLE construction and/or configuration. # N.B> There are implications to the CONSTRUCTION of a MODAL dialog regarding # the GLOBAL variable 'ctrlvar' whose NAME is specifed on the 'show' *IF* # it was declared as MODAL. # Primary is *it* becomes the target of any "actions" within the # dialog that expect to terminate it (successfully or not). The 'val', # given ON the 'invoke' should be whatever value you would want in a # default sense (Cancel, whatever), in the event the dialog is perhaps # closed via the window manager. # For a NON-MODAL dialog, ITS "actions" may be whatever is deemed # proper, including the 'dismiss' subcmd, or even a "destroy". # # show wNM [ctrlvar val] ?focusTarget? # Begins dialog processing and WAITs to be dismissed. Note that # if the window was defined as MODAL, "ctrlvar val" are REQUIRED. # When 'focusTarget' is provided, it should be the element within # 'wNM' where focus should be initially directed. RCode IS the # value of 'ctrlvar' (which itself must be GLOBALLY accessible) ############################################################################### proc Dialog {cmd wNM args} { global w switch -- $cmd { NONMODAL - MODAL { lassign {1 0} M(MODAL) M(NONMODAL) set w(mode$wNM) [expr {$M($cmd) * 2}] ;# To do syntax check @'show' if {![winfo exists $wNM]} { wm withdraw [toplevel $wNM {*}$args] if {$w(wSys)=="aqua"} { setAquaDialogStyle $wNM $M($cmd) } # Tell caller window NOW exists, but is UNPOPULATED return 0 # else Tell caller window already exists and MAY be displayed } { return 1 } } show { if {[llength $args] < $w(mode$wNM)} { error "Dialog $wNM: $cmd: missing args" } # Put it onscreen wm deiconify $wNM raise $wNM if {$w(mode$wNM)} { lassign $args ctrlvar val focalpt upvar #0 $ctrlvar var # Poke ctrlvar if user nukes the window (release tkwait & GRAB) set var $val ;# FORCE named ctrlvar to EXIST with a VALUE bind $wNM [list set $ctrlvar $var] # Direct focus for the dialog if {![string length $focalpt]} { set focalpt $wNM } set focalPrev [focus -displayof $wNM] focus $focalpt catch {tkwait visibility $wNM} catch {grab $wNM} ####################################################### # Begin dialog operation; waiting here until completion ####################################################### tkwait variable $ctrlvar catch {focus $focalPrev} catch {grab release $wNM} return $var } { lassign $args focalpt if {![string length $focalpt]} { set focalpt $wNM } after idle focus $focalpt } } dismiss { lassign [concat $args 0] retain ;# Save size and position? # Do Not CRASH: window MAY have been deleted catch { if {$retain} { set w(dlgeo,$wNM) [wm geometry $wNM] } catch { wm withdraw $wNM } } } } } ############################################################################### # A simple (reusable) 'entrybox' dialog. ############################################################################### proc Prompt { msg {preload {}} {title {Please provide}}} { global w set f .prompt if {![Dialog MODAL $f -bd 10]} { # Window was JUST created (withdrawn) and needs content wm title $f $title wm transient $f . wm group $f . # Don't destroy the window, just hide from view wm protocol $f WM_DELETE_WINDOW "Dialog dismiss $f" message $f.msg -text $msg -aspect 1000 entry $f.entry -textvariable w(val$f) pack $f.msg $f.entry [set b [frame $f.buttons]] -fill x pack $f.entry -pady 5 button $b.ok -text OK -default active -command "set w(ok$f) 1" button $b.cancel -text Cancel -command "set w(ok$f) 0" pack $b.ok -side left pack $b.cancel -side right bind $f.entry "$b.ok invoke ; break" bind $f.entry "$b.cancel invoke ; break" } # Initialize, run, and dismiss if {[set w(val$f) $preload] != {}} { $f.entry selection range 0 end } $f.entry icursor end Dialog show $f w(ok$f) 0 $f.entry Dialog dismiss $f # Provide STATUS result # N.B> Caller is responsible for retrieving the actual TEXT response # (from the WELL-KNOWN location "$w(val.prompt)") AFTER checking # the returned boolean STATUS of the Dialog (ZERO = user CANCELLED) return $w(ok$f) } ############################################################################### ############################################################################### ## BUILTIN Debugging facilities ############################################################################### ############################################################################### ############################################################################### # Internal variation (of 'Dbg' - see defn @top of file) specifically geared to # the planting of 'trace' stmts which expect to 'append args' to a cmd prefix # STRICTLY FOR DEVELOPMENT/INVESTIGATIONAL USAGE # example - # trace add ?what&name? ?ops? WatcH # ..... (area of code to watch - particularly for what=variable) # trace remove ?what&name? ?ops? WatcH # # BUGS: only implemented for 'variable' traces just now ############################################################################### proc WatcH {args} { if {[set op [lindex $args end]] in "read write unset"} { # It was a variable trace, so show its value (unless it was unset) if {$op == "unset"} {set value "-na-"} {upvar [lindex $args 0] value} puts stdout "$args\t\t$value" } } ############################################################################### # Modal msg dialog: defaults to error classification/decoration in front of "." # Args (except 1st) are optional and are identified by CONTENT, NOT position # N.B> Not ALL (-type)s are presently recognized ############################################################################### proc popmsg {msg args} { global g # derive args (after establishing defaults) lassign {error ok Error} severe type title parent foreach item $args { if {[string index $item 0] == "." && [winfo exists $item]} { set parent "-parent $item" } elseif {$item in {error warning info question}} {set severe $item } elseif {$item in {ok okcancel yesno yesnocancel}} {set type $item } else { set title $item } } # Notify and wait for acknowledgement (default display is in front of ".") return [tk_messageBox -message "$msg" -title "$g(name): $title" \ -type $type -icon $severe {*}$parent] } ############################################################################### # INTERNAL stacktrace generator (helps pin down WHERE something got executed) ############################################################################### proc trap-trace {{title "Trace"}} { set str "" for {set x [expr [info level]-1]} {$x > 0} {incr x -1} { append str "$x: [info level $x]\n" } popmsg $str info "$title" ;# pause until developer acknowledges } ############################################################################### # Pre-scan command line args to detect/collect ALL debug (-d?*) specifications # (because we EMBED tracking info INTO designated procs - NOT WRAP THEM!) # If ANY specs exist - we WRAP the 'proc' LANGUAGE STMT instead to act as a # SELECTOR of which yet-to-be-read procs to augment with tracking, IN ADDITION # to its normal task of actually DEFINING every such proc seen - from HERE ON! # #N.B> ANY proc NOT TO BE pre-processed must occur BEFORE reaching this line!! ############################################################################### if {[set DbuG [lsearch -inline -glob -all $argv {-d?*}]]!={}} {lappend DbuG -- rename ::proc ::proc_ ;# RENAME 'proc' stmt to NEW name, then USE to redefn proc_ proc {nam arglst body} { # Each argline supplied DbuG spec is COMPOSED of (encoded) idioms: # what type of proc? -> regular (dp) or widget (dw) # RE match in/ex-clude? -> exclude (!) or include () <- implied # OF a specific naming -> APPENDED regexp expression # N.B> Provided ORDER of specs may(?) result in unintended implications # (if so, it is was never anticipated to work in that fashion) foreach d $::DbuG { if {[switch -glob -- $d { -dw!?* {expr { [string equal -len 1 $nam "."] && [regexp [string range $d 4 end] $nam] ? [break] : 0}} -dw?* {expr { [string equal -len 1 $nam "."] && [regexp [string range $d 3 end] $nam]} } -dw {expr { [string equal -len 1 $nam "."]} } -dp!?* {expr {![string equal -len 1 $nam "."] && [regexp [string range $d 4 end] $nam] ? [break] : 0}} -dp?* {expr {![string equal -len 1 $nam "."] && [regexp [string range $d 3 end] $nam]} } -dp {expr {![string equal -len 1 $nam "."]} } default {set d 0}}]} then { proc_ $nam $arglst [concat {puts stderr \ "[string repeat " " [info level]][info level 0]";} $body] return } } proc_ $nam $arglst $body ;# <-- Do NOT insert ANY tracker in THIS proc } # N.B> 'proc' RUNs mostly @ SCRIPT-READ time, BUT MAY occur @ Run-time also } ############################################################################### ############################################################################### # HERE BEGIN THE PROCS (any BELOW this line are subject to execution tracking) ############################################################################### ############################################################################### ############################################################################### # Return the name of a temporary file # n - a naming fragment (to help identify where/why it was created) # forget!=0 - dont 'remember' the filename for the "destroy @ termination list" ############################################################################### proc tmpfile {n {forget 0}} { global g opts UniQ set tmpdir [file nativename $opts(tmpdir)] set fnam [file join $tmpdir [pid]-$n-[incr UniQ]] Dbg "temp file $fnam" set access [list RDWR CREAT EXCL TRUNC] set perm 0600 if {[catch {open $fnam $access $perm} fid ]} { # something went wrong error "Failed creating temporary file: $fid" } close $fid if {!$forget} {lappend g(tempfiles) $fnam} return $fnam } ############################################################################### # Execute an external command, optionally storing STDOUT into a given filename # Returns the 3-tuple list "$stdout $stderr $exitcode" # # Operation is sensitive to the EXISTANCE (not value) of flag "ASYNc(trigger)" # to run in ASYNChronous .vs. BLOCKing mode. When running ASYNC, an event loop # is provided for dispatching tasks encountered WHILE the command is processed ############################################################################### proc run-command {cmd {out {}}} { global ASYNc errorCode # Arrange for requested output format (given execution constraints) # N.B> 'fout' will become one of: a channel, a cmd indirection, or empty. if {[info exists ASYNc(trigger)]} { if {[set fout $out] != {}} { set fout [open $out wb] chan configure $fout -buffering none } {upvar #0 ASYNc(out) STDout} } elseif {[set fout $out] != {}} {set fout "\">$out\""} # Establish default answers set STDerr [set STDout ""] set exitcode 0 set cmderr [tmpfile "cmderr" 1] ;# retain filename locally; WE will whack # (N.B> stderr redirection prevents 'catch' from assuming msgs -> errors) # But the big difference in ASYNC .vs. BLOCKing is how to deal with STDOUT if {[info exists ASYNc(trigger)]} { Dbg "Cmd running in ASYNC mode" # Startup the cmd (so we can attach its stdout to the event loop) ... # ..where an (anonymous) handler will snag any/all STDOUT produced, but # more importantly WATCHES for an EOF, telling us the cmd has completed set cmdout [open "|$cmd \"2>$cmderr\"" rb] chan configure $cmdout -blocking 0 -buffering none chan event $cmdout readable [list apply {{fin fptr} { global ASYNc if {$fptr != {}} { puts -nonewline $fptr [chan read $fin] } else {append ASYNc(out) [chan read $fin]} if {[chan eof $fin]} {set ASYNc(events) 0} }} $cmdout $fout] set ASYNc(events) 1 #### vwait ASYNc(events) ;# wait here until we see EOF from handler above #### chan configure $cmdout -blocking 1 ;# (N.B> to get errorcodes) if {[set failed [catch "close $cmdout"]]} {set errCODE $errorCode} Dbg "Back from ASYNC cmd: rc($failed)" if {$fout != {}} {close $fout} } elseif {[set failed [catch "exec $cmd $fout \"2>$cmderr\"" STDout]]} { set errCODE $errorCode ;# Snag this before it can get overwritten } # Suck out any error messages that MAY have been produced (and whack file) catch { set hndl [open "$cmderr" r] set STDerr [read $hndl] close $hndl file delete $cmderr } if {$failed} { switch -- [lindex $errCODE 0] { "CHILDSTATUS" { set exitcode [lindex $errCODE 2] } "POSIX" { if {$STDerr == ""} { set STDerr $STDout } set exitcode -1 } default { set exitcode -1 } } } #Dbg "runcmd RESULTS($exitcode): out([string length $STDout])\ err([string length $STDerr]) appropriate ?" return [list "$STDout" "$STDerr" "$exitcode"] } ############################################################################### # Populate the 'ndx'th finfo FILE via its accompanying finfo 'tmp' SCM command # Returns descriptive msg(s) if something fails; a NUL string on Success ############################################################################### proc scm-chkget {ndx} { global finfo # 'ndx' is a number POSSIBLY prefixed by an 'a' (for ancestor) # adjust the NAMING for 'finfo(xxx)" elements accordingly set A "a" ; if {[string index "$ndx" 0] == $A} { set ndx [string range $ndx 1 end] } { set A "" } if {![info exists finfo(${A}pth,$ndx)]} { set finfo(${A}pth,$ndx) "[tmpfile scm$ndx]" } Dbg "scm-chkget ($ndx) -> '$finfo(${A}tmp,$ndx)': $finfo(${A}pth,$ndx)" lassign [run-command "$finfo(${A}tmp,$ndx)" "$finfo(${A}pth,$ndx)"] \ scmOUT scmERR scmRC # Remember to postproccess (if needed) and ... if {!$scmRC} { if {[info exists finfo(${A}pproc,$ndx)]} { $finfo(${A}pproc,$ndx) "$finfo(${A}pth,$ndx)" } # ... return the erased cmd (DO NOT UNSET) to indicate Success return [set finfo(${A}tmp,$ndx) ""] } # This atrocity originated because CVS refuses to extract the Repo version # of a CONFLICTED file - but WITHOUT posting any visible REASON ... WTF? ! # So look for this and inject our OWN error msg if {[set msg "$scmERR\n$scmOUT"] == "\n" \ && [string match {cvs[ .]*} $finfo(${A}tmp,$ndx)]} { set msg "Is this a CONFLICTed file(?): [lindex $finfo(${A}tmp,$ndx) end]" } # Send messages back to caller only on failure return "$msg" ;# Failed! } ############################################################################### # Filter PVCS output files that have CR-CR-LF end-of-lines ############################################################################### proc filterCRCRLF {file} { set outfile [tmpfile CRCRLF] set inp [open $file r] set out [open $outfile w] fconfigure $inp -translation binary fconfigure $out -translation binary set CR [format %c 13] while {![eof $inp]} { set line [gets $inp] if {[string length $line] && ![eof $inp]} { regsub -all "$CR$CR" $line $CR line puts $out $line } } close $inp close $out file rename -force $outfile $file } ############################################################################### # Return the smallest of two values ############################################################################### proc min {a b} { return [expr {$a < $b ? $a : $b}] } ############################################################################### # Return the largest of two values ############################################################################### proc max {a b} { return [expr {$a > $b ? $a : $b}] } ############################################################################### # Align (or force set on/off) Info window item visibility ############################################################################### proc do-show-Info {{which {}} {force {}}} { global g w opts if {$force != {}} { set opts($which) $force } # Detect if/when text Info windows should be mapped OR unmapped if {$opts(showln) || $opts(showcbs) || $g(is3way)} { if {! [winfo ismapped $w(LeftInfo)]} { grid $w(LeftInfo) -row 0 -column 1 -sticky nsew grid $w(RightInfo) -row 0 -column 0 -sticky nsew } } elseif {[winfo ismapped $w(LeftInfo)]} { grid forget $w(LeftInfo) grid forget $w(RightInfo) } # The mergeInfo window (for now) is ALWAYS 'on' ... # However if we ever create an opt() for the "contrib markers" # then simply uncomment this to get it to turn on/off like above # if {$opts(showln) || $opts(XXX-contrib-XXX)} { # if {! [winfo ismapped $w(mergeInfo)]} { # grid $w(mergeInfo) -row 0 -column 0 -sticky nsew # } # } elseif {[winfo ismapped $w(mergeInfo)]} { # grid forget $w(mergeInfo) # } # In any event SOMETHING changed - ensure we utilize canvas properly cfg-line-info } ############################################################################### # Transliterate "text-tagging" precedences for Font/Bg/Fg canvas plotting ############################################################################### proc translit-plot-txtags {twdg} { global g opts # The neccessity of this routine stems from the USER view being one of # setting 'text-tags' for highlighting various meta-data pgm elements, # because THAT was the former implementation. Internally we have shifted # to a Canvas based technique (to reduce textline aligment issues since # version TK8.5), but must NOW cope with the reality of canvas-text NOT # providing a 'tag-precedence-stack' mechanism. Emulating a "what-would- # have-happened" approach is better than redefining the USER view of the # preferences (or auto-magically MAPPING the existing user base). # # Technique is to pre-compute how the tagging-specified user input would # be precedence-stacked by the pgm so we can setup direct access to "N" # composite sets of values as needed when canvas-rendering the meta-data. # Note that TkDiff uses MORE than simple precedence and thus SOME sets # might only be UTILIZED by the Left or Right view, or under values of # OTHER related option settings -- thus the NAMING of each set is an # encoding that 'plot-line-info' intends to access randomly as needed. # First establish a BASE precedence layer (just the Text widget settings) # (what you get if NO user tagging was explicitly supplied [unlikely]). # For the 3 key display values we support: Font Fg Bg # plus 2 font-derivative metrics we NEED later: Ascent Ascent+Descent # (PLUS a running MAX of certain key-character widths across ALL fonts) set Fg [$twdg cget -foreground] ;# foreground set Bg [$twdg cget -background] ;# background set Fnt "[$twdg cget -font]" ;# font set Aft [set Hft [font metrics $Fnt -ascent]] ;# ascent of font incr Hft [font metrics $Fnt -descent] ;# height of font set Dw [font measure $Fnt "8"] ;# Digit width set Cw [font measure $Fnt "+"] ;# ChgBar width set Sw [font measure $Fnt " "] ;# Space width set Mw [font measure $Fnt "M"] ;# Em width # Begin the database with a snapshot of the "settings" for what is # (effectively) the "textopt" tag layer (plain old file lines) lappend DB [set nam t] "{$Fnt} $Aft $Hft $Fg $Bg" # Now, OVERLAY in PRECEDENCE ORDER, successive basic tags, recording each foreach t {difftag currtag} { # Turn each tagging definition into a "look up table"(lut) of its # contents, then look for any option names of interest, and process # whichever ones are found (similar to above BASE setting derivation) append nam [string index $t 0] array set lut $opts($t) foreach op [array names lut -regexp {\-((f|b)g|(fo[rn]|ba))}] { # (allow for abbreviations of the V8.5 option keywords) switch -glob -- $op { "-for*" - "-fg" { set Fg $lut($op) } ;# fg "-b*" { set Bg $lut($op) } ;# bg "-fon*" { set Fnt $lut($op) ;# font set Aft [set Hft [font metrics $Fnt -ascent]] ;# ascent incr Hft [font metrics $Fnt -descent] ;# height set Dw [max $Dw [font measure $Fnt "8"]] ;# maximal Dw set Cw [max $Cw [font measure $Fnt "+"]] ;# maximal Cw set Sw [max $Sw [font measure $Fnt " "]] ;# maximal Sw set Mw [max $Mw [font measure $Fnt "M"]] ;# maximal Mw } } } # Append this snapshot of values to the overall database lappend DB $nam "{$Fnt} $Aft $Hft $Fg $Bg" array unset lut } # DB entries 't'(text) 'td'(diff) and 'tdc'(curr) now exist IN THAT ORDER # # Next construct the mutually exclusive variations that are specifically # composited by the pgm when adds/chgs/dels are detected in the input files # onto EACH of the LAST TWO CATEGORIES. Note that specific Info-only # situations (eg. opts(colorcbs), highlighting) are NOT addressed here and # is handled during 'plot-line-info' rendering directly. foreach t {instag chgtag deltag overlaptag} { # Re-establish base settings prior to overlay of EACH mutual tag foreach {nam base} [lrange $DB 2 5] { lassign $base Fnt Aft Hft Fg Bg # Derive new name, then turn each tagging definition into a # "look up table"(lut) of its contents, looking for the option # names of interest, overlaying values found (same as before) # Note that each new name is a MAPPING into its Chgbar mark append nam [string map {i + c ! d - o ?} [string index $t 0]] array set lut $opts($t) foreach op [array names lut -regexp {\-((f|b)g|(fo[rn]|ba))}] { # (again, allow for abbreviations of the V8.5 option keywords) switch -glob -- $op { "-for*" - "-fg" { set Fg $lut($op) } ;# fg "-b*" { set Bg $lut($op) } ;# bg "-fon*" { set Fnt $lut($op) ;# font set Aft [set Hft [font metrics $Fnt -ascent]] ;# ascent incr Hft [font metrics $Fnt -descent] ;# height set Dw [max $Dw [font measure $Fnt "8"]] ;# maximal Dw set Cw [max $Cw [font measure $Fnt "+"]] ;# maximal Cw set Sw [max $Sw [font measure $Fnt " "]] ;# maximal Sw set Mw [max $Mw [font measure $Fnt "M"]] ;# maximal Mw } } } # Append this snapshot of value to the overall database lappend DB $nam "{$Fnt} $Aft $Hft $Fg $Bg" array unset lut ;# throw away all lut tuples for next pass } } # Historical Note (Re: TKDIFF 4.2 and earlier) # The highest precedence tag, "inlinetag", is only designed for (thus # overrides) 'chgtag' defined values. However, it is ONLY ever APPLIED to # char-ranges within the main L/R-Text widgets. Thus its color/font opts # NEVER applied to the actual RENDERING of Info data, despite them having # been (in the past) CONFIGURED into the Lnum and CB *Text widgets*. Thus # it AFFECTS nothing and as such, this emulation ignores it. # Finally, post the data needed by 'cfg-line-info' to compute canvas width # AND the complete database of precomputed attrs for 'plot-line-info' with # its 11 values: "t, td, td+, td!, td-, td?, tdc, tdc+, tdc!, tdc-, tdc?" set g(scrInf,cfg) "$Dw $Cw $Sw $Mw" set g(scrInf,tags) $DB } ############################################################################### # Resolve present Info window plotting configuration (AFTER any chngd settings) ############################################################################### proc cfg-line-info {} { global g w opts # First obtain the maximal Text widget font measurements lassign $g(scrInf,cfg) wDig wChg wSpc wEm # Then establish an X position for plotting the PRIMARY Info elements such # that the maximal line number (if visible) will FIT to its left # Values (mX, tX) for windows (Merge .vs. Text) WILL need to be distinct set g(scrInf,mX) [set g(scrInf,tX) \ [expr {$opts(showln) ? $wDig*$g(lnumDigits) : 0}]] # In a 3way Diff situation, make room for a Textwin "ancestral indicator" if {$g(is3way)} { incr g(scrInf,tX) $wEm } # MergeInfo always (for now) adds space for ITS (left/right) markers # (but it COULD be done as a pref, by replacing 'true' with some var) if {[set sz [expr {( true ? $wChg+$wSpc : 0) + $g(scrInf,mX)}]]} { $w(mergeInfo) configure -width [incr sz 3] incr g(scrInf,mX) ;# 'slides' padding to 1pxl on left and 2pxl right } # Add to 'tX' any space needed for Changebars (if visible) which will # left-justify to that position defined above. Then INCREASE that amount # (+5pxl for padding) and apply it to BOTH Text Info canvases, calling it # "scrInf,XX" (for plotting), making the canvas EXACTLY wide enough # (does NOTHING if meta-data visibility options are ALL turned off) if {[set sz [expr {($opts(showcbs) ? $wChg+$wSpc : 0) + $g(scrInf,tX)}]]} { $w(LeftInfo) configure -width [incr sz 5] $w(RightInfo) configure -width [set g(scrInf,XX) $sz] incr g(scrInf,tX) 3;# 'slides' padding to 3pxl on left and 2pxl right } } ############################################################################### # Plot text widget line numbers and/or contrib markers in adjoining info canvas ############################################################################### proc plot-merge-info {args} { global g w opts # Ignore this routine if not needed, havent gotten far enough in processing # -OR- its trigger will have zero effect on the displayed content if {!$g(showmerge) || $g(startPhase) < 2 \ || ([llength $args] > 0 && [lindex $args 0 1] in $g(benign))} return # Initialize: Empty the canvas # Identify the line range of the CDR # Import the 'tag' attr table and make it random access # Begin with NO current attr group $w(mergeInfo) delete all lassign [$w(mergeText) tag ranges currtag] sCDR eCDR array set attr $g(scrInf,tags) set aGRP {} # Begin at 1st VISIBLE screen text line, converting its indice->integer set Lnum [expr {int([$w(mergeText) index @0,0])}] # Map/plot Lnums # Line numbers here are identical to widget indices. Markers derive # from the TAGNAMES used for each line of a given diff REGION. # (PRESUMES the canvas & text widgets are physically aligned!!) # Stops when we walk beyond the visible range of the Text widget lines, # -OR- we discover the EXTRA "last line" at the bottom of the widget set LastLnum [expr {int([$w(mergeText) index end-1lines])}] while {[llength [set dline [$w(mergeText) dlineinfo $Lnum.0]]] > 0} { if {$Lnum == $LastLnum} {break} ;# ignore extra last line # Detect/decode any diff(R/L) tag on the line (if it even exists) # (the tag NAME encodes what SIDE the merge contribution came from) # N.B. tags report in priority order, thus ZERO should be where to find # EITHER 'diff(R/L)' (each being of lowest prio & mutually exclusive) switch [lindex [$w(mergeText) tag names $Lnum.0] 0] { diffR { set aNewGRP [expr {$Lnum<$sCDR || $Lnum>=$eCDR ? "td" : "tdc"}] set side " >" } diffL { set aNewGRP [expr {$Lnum<$sCDR || $Lnum>=$eCDR ? "td" : "tdc"}] set side " <" } default { set side {} ; set aNewGRP "t"} } # Instantiate correct 'tag' attribute group (if it changed) if {"$aNewGRP" != "$aGRP"} { lassign $attr([set aGRP $aNewGRP]) Fnt Asc Hgt Fg Bg } # We want to plot on the same BASELINE as the text widget, but it # must be EMULATED as canvas '-anchor' provides NO SUCH setting. lassign $dline na y na na bl ;# extract TxT y and baseline incr y $bl ;# move y to its baseline then UP by the incr y -$Asc ;# "plot font" ascent (=eff. NE/NW edge) # Plot the contributory-side marker (if any) if { "$side" != {}} { $w(mergeInfo) create text $g(scrInf,mX) $y -anchor nw \ -fill $Fg -font $Fnt -text "$side" } # Plot LineNum if requested if {$opts(showln)} { $w(mergeInfo) create text $g(scrInf,mX) $y -anchor ne \ -fill $Fg -font $Fnt -text "$Lnum" } incr Lnum } } ############################################################################### # Plot text widget line numbers and/or change bars in adjoining info canvas ############################################################################### proc plot-line-info {side args} { global g w opts # Ignore this routine if we havent gotten far enough into the processing # -OR- everything that might have displayed is turned OFF anyway if {$g(startPhase) < 2 \ || ((!$g(is3way)) && (!$opts(showln)) && (!$opts(showcbs)))} return # Create session-persistent constants for NOW and FUTURE use if {! [info exists g(LR,Left)]} { set g(LR,Left) [list Snum Enum Pad Ofst Cbar] set g(LR,Right) [list Snum Enum na na na Pad Ofst Cbar] } # Only redraw when args are null (meaning we were called by a binding) # or when called by the trace and the widget action might potentially # change the height of a displayed line. if {[llength $args] == 0 || [lindex $args 0 1] ni $g(benign)} { # Initialize: Empty the canvas # Import the 'tag' attr table and make it random access # Begin with NO current attr group # Map the index of the 'current diff' to refer to g(DIFF) # Presume default first attr-group is a NON hunk-line $w(${side}Info) delete all array set attr $g(scrInf,tags) set aGRP {} set gPos [hunk-ndx [hunk-id $g(pos)] DIFF] set aNewGRP "t" # Begin at 1st VISIBLE screen text line, converting its indice->integer set Lnum [expr {int([$w(${side}Text) index @0,0])}] # Now, (if >1 exists) binary-search for an APPROPRIATE start "scrInf,*" # entry to allow mapping 'Lnum' BACK to its ORIGINAL linenumber. We # want the CLOSEST item (preferrably ABOVE) the target Lnum value, but # BELOW is used when Lnum > last line of the final hunk. When NONE # exist (files are identical), the screen numbers ARE the real numbers, # so a dummy entry allows the remaining code to function properly. if {[set i $g(COUNT)]} { # N.B> 'rngeSrch' (unlike hunk-id, et.al) uses ZERO-based indices # so increment the index UNLESS it comes back as the last entry if {[set i [rngeSrch DIFF $Lnum "scrInf,"]] != $g(COUNT)} {incr i} lassign $g(scrInf,[set hID [hunk-id $i DIFF]]) {*}$g(LR,$side) } else {lassign { 0 0 0 0 "" 0 0 "" } {*}$g(LR,$side) } # When a 3way is active, it REQUIRES a per-line 'ancestral' mapping # (so figure out where to START that mapping as well) if {$g(is3way)} { set anc(max) [llength $g(d3$side)] set anc(ndx) [rngeSrch d3$side [expr {$Lnum - $Ofst}]] if {$anc(ndx) < $anc(max)} {lassign \ [lindex $g(d3$side) $anc(ndx)] anc(fst) anc(lst) anc(mrk) } else { lassign {0 0 " "} anc(fst) anc(lst) anc(mrk) } } # Map/plot Lnums, advancing as needed through any mapping entries. # Line number translation consists of USING variables already set but # WATCHING for when to ADVANCE to the next sequential mapping entry. # (PRESUMES the canvas & text widgets are physically aligned!!) # Stops when we walk beyond the visible range of the Text widget lines, # -OR- we discover the EXTRA "last line" at the bottom of the widget set LastLnum [expr {int([$w(${side}Text) index end-1lines])}] while {[llength [set dline [$w(${side}Text) dlineinfo $Lnum.0]]] > 0} { if {$Lnum == $LastLnum} {break} ;# ignore extra last line # Waterfall test detects phase of WHAT plots WITHIN a hunk boundary # and establishes which tag-derived display attribute group to use # (NB. purely Pad'ded lines always skip plotting altogether) if {$i > 0 && $Lnum >= $Snum} { if {$Lnum > ($Enum - $Pad)} { if {$Lnum > $Enum} { if {$i < $g(COUNT)} { # Step forward to the next hunk mapping # loading the NEXT scrInf,* entry settings set hID [hunk-id [incr i] DIFF] lassign $g(scrInf,$hID) {*}$g(LR,$side) if {[info exists g(overlap$hID)]} {set Cbar "?"} # Restart loop if 'Lnum' is NOW INSIDE the params # of the newly read-in hunk (to support abutted # hunks created by the Split/Combine feature) if {$Lnum >= $Snum} continue # Special fixup needed when FINAL hunk had padding } elseif {$Pad} {incr Ofst $Pad; set Pad 0 } set CB false ; set aNewGRP "t" ;# Is beyond entry } else { incr Lnum ; continue } ;# A PADDING line } else { set CB $opts(showcbs) ;# A DIFFed line set aNewGRP [expr {$i==$gPos ? "tdc$Cbar":"td$Cbar"}]} } else {set CB false ; set aNewGRP "t" } ;# Is before entry # Instantiate correct 'tag' attribute group (if it changed) if {"$aNewGRP" != "$aGRP"} { lassign $attr([set aGRP $aNewGRP]) Fnt Asc Hgt Fg Bg } # We want to plot on the same BASELINE as the text widget, but it # must be EMULATED as canvas '-anchor' provides NO SUCH setting. lassign $dline na y na na bl ;# extract TxT y and baseline incr y $bl ;# move y to its baseline then UP by the incr y -$Asc ;# "plot font" ascent (=eff. NE/NW edge) # FINALLY plot THIS Lnum and/or ChgBar per the CURRENT options # Do ChgBars 1st (more often skipped), with NW-corner as locpt. # Subsequent Linenumber will uses NE-corner at the SAME locpt. # (Annoyingly, canvas text has NO "Bg"-cell - must emulate!) # Weird flipping of colors just mimics the way tags were APPLIED # when this was all done in a Text widget (as of TkDiff 4.2) if {$CB && "$Cbar" != ""} { # Highlight Chgbars ? (i.e. colored Bg or Fg) if {$opts(tagcbs)} { if {$opts(colorcbs)} { switch -- $Cbar { "!" - "?" { set Cfg [set Cbg $opts(mapchg)] } "+" { set Cfg $opts(mapdel) ; set Cbg $opts(mapins) } "-" { set Cfg $opts(mapins) ; set Cbg $opts(mapdel) } } } else { lassign "$Fg $Bg" Cfg Cbg } # Make/plot a fontsized ChangeBar "background rect" set yy $Hgt set Dims [list $g(scrInf,tX) $y $g(scrInf,XX) [incr yy $y]] $w(${side}Info) create rect $Dims -fill $Cbg -outline $Cbg } else { set Cfg $Fg } $w(${side}Info) create text $g(scrInf,tX) $y -anchor nw \ -fill $Cfg -font $Fnt -text " $Cbar" } if {$opts(showln)} { # Highlight LineNum ? if {$opts(tagln) && "$Cbar" != ""} { # Make/plot a fontsized Lnum "background rect" if {$g(is3way)} { set xx [lindex $g(scrInf,cfg) 3] ;# ancestral mark ofst } { set xx 0 } set yy $Hgt set Dims [list $g(scrInf,tX) $y [incr xx] [incr yy $y]] $w(${side}Info) create rect $Dims -fill $Bg -outline $Bg } $w(${side}Info) create text $g(scrInf,tX) $y -anchor ne \ -fill $Fg -font $Fnt -text "[expr {$Lnum - $Ofst}]" } # Insert the 'ancestral' marker if a 3way is in progress # (and we haven't walked off the list of markers altogether) if {$g(is3way) && $anc(ndx) < $anc(max) \ && ($Lnum - $Ofst) >= $anc(fst) && ($Lnum - $Ofst) <= $anc(lst)} { # Markers generated from OTHER side display in inverse video, # thus make/plot a fontsized marker "background rect" if {[string is upper $anc(mrk)]} { set xx [lindex $g(scrInf,cfg) 3] ;# ancestral mark width set yy $Hgt set Dims [list 1 $y $xx [incr yy $y]] $w(${side}Info) create rect $Dims -fill $Fg -outline $Fg set Fg3 $Bg; # (which forces us to flip the text color) } else { set Fg3 $Fg } $w(${side}Info) create text 1 $y -anchor nw \ -fill $Fg3 -font $Fnt -text $anc(mrk) # Step map forward to next triplet (when 'last' has been used) if {$anc(lst) == $Lnum - $Ofst} { lassign [lindex $g(d3$side) [incr anc(ndx)]] \ anc(fst) anc(lst) anc(mrk) } } incr Lnum } } } ############################################################################### # Split file containing CVS (or other?) conflict markers into 2 (3?) tmp files # name Name of input file containing conflict markers # ndx Highest CURRENT finfo indice (entries added here must be higher) # whose optional identity Augmentation (eg. the SCM it came from?) # # N.B> Its possible a THIRD file (an ancestor) may be seen in the input format # (file+marker syntax is as produced by 'diff3 -m Mine [Ancestor] Theirs') ############################################################################### proc split-conflictfile {name ndx {whose {}}} { global g finfo if {[catch {set input [open $name r]}]} { fatal-error "Couldn't open file '$name'" } # Must derive the SPECIFIC finfo indices we plan to populate # (due to the processing technique being a parallel, NOT sequential one) # ie. 'L'eft 'R'ight (and 'A'ncestor when needed) set R 1 set A [expr {[incr R [set L [incr ndx]]] / 2}] # Initialize the files/streams/names/flags to start (beyond 1st 4 - empty!) # # N.B> CANT create finfo(albl,$ndx) until data is SEEN (it triggers 3way!) lassign "7 [open [set finfo(pth,$L) [tmpfile cf1]] w] \ [open [set finfo(pth,$R) [tmpfile cf2]] w] \ [open [set finfo(apth,$A) [tmpfile cfa]] w]" \ out f1 f2 fa Re1 finfo(atmp,$A) \ finfo(lbl,$L) finfo(tmp,$L) finfo(lbl,$R) finfo(tmp,$R) # Read/copy input into 'out' files as directed by embedded markers while {[gets $input line] >= 0} { # The FIRST marker tells us whose marking FORMAT to follow if {$Re1 == ""} { if {[regexp {^<<<<<<<* +} $line]} { # This maps 'diff3-like' merge markers set Re1 {^<<<<<<<* +(.*)} set Re2 {^=======*} set Re3 {^>>>>>>>* +(.*)} set Re4 {^\|\|\|\|\|\|\|* +(.*)} } elseif {[regexp {^>>>>>>>* +} $line]} { # This maps ??WHOSE?? markers # (and why did they invent their OWN?) # (***Pls ADD identifying comment!!***) set Re1 {^>>>>>>>* +(.*)} set Re2 {^<<<<<<<* +(.*)} set Re3 {^=======*} set Re4 {^\|\|\|\|\|\|\|* +(.*)} } } # Dont bother with matching until we find the first marker if {$Re1 != ""} { if {[regexp $Re1 $line na name]} { # First Marker: following data was from SECOND file if {$finfo(lbl,$R) == "" && $name != ""} { set finfo(lbl,$R) "[shortNm $name] ($whose Cflct)" } set out 2 } elseif {[regexp $Re2 $line na name]} { # Second Marker: following data was from FIRST file if {$finfo(lbl,$L) == "" && $name != ""} { set finfo(lbl,$L) "[shortNm $name] ($whose Cflct)" } set out 1 } elseif {[regexp $Re3 $line na name]} { # Third Marker: following data is COMMON to ALL files if {$finfo(lbl,$L) == "" && $name != ""} { set finfo(lbl,$L) "[shortNm $name] ($whose Cflct)" } set out 7 # FINDING the 4th Marker indicates there WAS an Ancestor!! } elseif {[regexp $Re4 $line all name]} { # Fourth Marker: following data was from Ancestor file if {![info exists finfo(albl,$A)] && "$name" != ""} { set finfo(albl,$A) "[shortNm $name] ($whose Cflct)" } set out 4 } else { if {$out & 1} { puts $f1 $line } if {$out & 2} { puts $f2 $line } if {$out & 4} { puts $fa $line } } } else { puts $f1 $line puts $f2 $line puts $fa $line } } close $input close $f1 close $f2 close $fa # If for some reason no names were detected, invent SOMETHING ... # N.B> Existence of an Ancestor is IMPLICIT within the data if {$finfo(lbl,$L) == ""} {set finfo(lbl,$L) "theirs ($whose Cflct)"} if {$finfo(lbl,$R) == ""} {set finfo(lbl,$R) "ours ($whose Cflct)"} # Cleanup & return highest indice used (Ancestors NEVER get counted) if {![info exists finfo(albl,$ndx)]} {array unset finfo "a\[pt]*,$A"} return $R } ############################################################################### # Derive the Src Code Management systems that seem VALID for given dir or file ############################################################################### proc scm-detect {fn {extra {}}} { regsub -all {\$} $fn {\$} fn ;# (Backslash any '$' ciphers as literal) # Use dirname OF argument if it is not a directory already if {[file isdirectory $fn]} {set dnam $fn} {set dnam [file dirname $fn]} # There are basically FOUR 'possibilities' for detection: # 1 those determined by the naming of the file itself # 2 those that require some ADJOINING file structure naming # 3 those requiring external-executables to be invoked # 4 those that depend on existance of certain ENV variables # ### (unknown if a better order exists: one below is purely historical) ### *My* gut feeling is the precedence described above should be followed ### (which is NOT completely the case as it exists here) however, as some ### cases are combo/subsets of others there is plenty of room for debate. # # In any event, this is now a voting process (former if-else chain) where # the user gets to pre-state their choice PROVIDED its an allowed one. lappend scms if {[file isdirectory [file join $dnam CVS]]} { lappend scms CVS } if {[is-repo-dir ".svn" $dnam]} { lappend scms SVN } if {[is-git-repository]} { lappend scms GIT } if {[regexp {://} $fn]} { lappend scms SVN } if {[sccs-is-bk]} { lappend scms BK } if {[file isdirectory [file join $dnam SCCS]]} { lappend scms SCCS } if {[file isdirectory [file join $dnam RCS]]} { lappend scms RCS } if {[file isfile $fn,v]} { lappend scms RCS } if {[file exists [file join $dnam vcs.cfg]] || \ [info exists ::env(VCSCFG)]} { lappend scms PVCS } if {[info exists ::env(P4CLIENT)] || \ [info exists ::env(P4CONFIG)]} { lappend scms Perforce } if {[info exists ::env(ACCUREV_BIN)]} { lappend scms Accurev } if {[info exists ::env(CLEARCASE_ROOT)]} { lappend scms ClearCase } if {[is-repo-dir ".hg" $dnam]} { lappend scms HG } # We occasionally need to ADD a 'pseudo SCM' to the end of a NONEMPTY list if {$extra != "" && [llength $scms]} {lappend scms $extra} return $scms } ############################################################################### # Decide which Src Code Managment system is expected to obtain the current file ############################################################################### proc scm-elect {scms vote} { #Dbg "Elect Candidates($scms) Vote($vote) for [info level -1]" # Simply apply the users vote # N.B> This makes it APPEAR that either SCM meta-value (Auto or None) # always results in just TAKING the top entry - the trick is that when # 'scms' was setup by 'newDiff' it likely CONTAINS 'None' as a # candidate value, making it electable here, based on the 'vote' # This allows the caller to recognize that access was BLOCKed not MISSING if {$vote in $scms} {return $vote ;# new democratic way ...user choice } else {return [lindex $scms 0]} ;#ye olde way...1st found } ############################################################################### # Obtain a revision of a file: # fn requested file name # ndx index in finfo array to place data ('-'ndx implies Ancestor naming) # rev "" implies SCM will use ITS default (generally 'most recent') # Scm if !Null, which SCM to use (avoids lookup) # Returns 0 (Success) or 1 (Failed + diagnostic messages produced) ############################################################################### proc get-file-rev {fn ndx {rev ""} {Scm {}}} { global g opts finfo tcl_platform # First, some simple initializations common to ALL regsub -all {\$} $fn {\$} fn ;# (Ensure any '$' ciphers remain literal) set cmdsfx "" ;# To prevent 'exec'-spoofing on Windows platform(?) if {$tcl_platform(platform) == "windows"} { set cmdsfx ".exe" } # Ancestor files are stored into a slightly adjusted array element name if {$ndx < 0} {set A "a"; set ndx [expr {-1 * $ndx}]} {set A ""} # PRESUME eventual success ... **THEN** ... set msg {} # ... DETECT and FORMULATE the appropriate SCM command to request the file # N.B> The 'None' choice is PRESERVED when it was originally present if {"" == $Scm} { set Scm [expr {!($ndx & 1)}] ;# Get from the correct side set ScmVote [lindex $g(scmPrefer) $Scm] ;# obtain CURRENT preference set Scm [expr {"None" in $finfo(scm[incr Scm])? "None" : ""}] ;# None? set Scm [scm-elect [scm-detect $fn $Scm] $ScmVote] ;# & resolve the Scm } # HOWEVER - not all SCMs can handle a URL; report instead when SCM cant if {$Scm == "SVN" || ![regexp {://} $fn]} { switch -- $Scm { CVS { append cmd "cvs" $cmdsfx if {[set lbl $rev]==""} {set lbl "HEAD"} {set rev "-r $rev"} # For CVS, if it isn't checked out, there is neither a CVS nor RCS # directory. It will however have a ,v suffix just like rcs. # (There is not necessarily a RCS directory for RCS, either...) # (however, if not, then the file will ALWAYS have a ,v suffix.) set finfo(${A}lbl,$ndx) "[shortNm $fn] ($Scm $lbl)" set finfo(${A}tmp,$ndx) "$cmd update -p $rev \"$fn\"" } SVN { append cmd "svn" $cmdsfx if {[set lbl $rev]==""} {set lbl "BASE"} {set rev "-r $rev"} # Subversion directly ALLOWS a URL instead of a true filename set finfo(${A}lbl,$ndx) "[shortNm $fn] ($Scm $lbl)" set finfo(${A}tmp,$ndx) "$cmd cat $rev \"$fn\"" } GIT { if {[is-git-repository]} { # Only works if you are actually INSIDE the work tree append cmd "git" $cmdsfx; # Default revision is the 'stage' if {[set lbl $rev]==" " || $rev==""} { set lbl "--staged" ; set rev ":"} {set rev "$rev:"} set finfo(${A}lbl,$ndx) "[shortNm $fn] ($Scm $lbl)" set finfo(${A}tmp,$ndx) \ "$cmd show \"$rev[exec $cmd rev-parse --show-prefix]$fn\"" } {set msg "Please re-start from within a Git work tree."} } BK { append cmd "bk" $cmdsfx if {[set lbl $rev]==""} {set lbl "HEAD"} {set rev "-r$rev"} set finfo(${A}lbl,$ndx) "[shortNm $fn] ($Scm $lbl)" set finfo(${A}tmp,$ndx) "$cmd get -p $rev \"$fn\"" } SCCS { append cmd "sccs" $cmdsfx if {[set lbl $rev]==""} {set lbl "HEAD"} {set rev "-r$rev"} set finfo(${A}lbl,$ndx) "[shortNm $fn] ($Scm $lbl)" set finfo(${A}tmp,$ndx) "$cmd get -p $rev \"$fn\"" } RCS { append cmd "co" $cmdsfx if {[set lbl $rev]==""} {set lbl "HEAD"} set finfo(${A}lbl,$ndx) "[shortNm $fn] ($Scm $lbl)" set finfo(${A}tmp,$ndx) "$cmd -p$rev \"$fn\"" } PVCS { append cmd "get" $cmdsfx if {[set lbl $rev]==""} {set lbl "HEAD"} {set rev "-r$rev"} set finfo(${A}lbl,$ndx) "[shortNm $fn] ($Scm $lbl)" set finfo(${A}tmp,$ndx) "$cmd -p $rev \"$fn\"" set finfo(${A}pproc,$ndx) "filterCRCRLF" } Perforce { append cmd "p4" $cmdsfx if {[set lbl $rev]==""} {set lbl "HEAD"} {set rev "#$rev"} set finfo(${A}lbl,$ndx) "[shortNm $fn] ($Scm $lbl)" set finfo(${A}tmp,$ndx) "$cmd print -q \"${p4file}$rev\"" } Accurev { append cmd "accurev" $cmdsfx if {[set lbl "$rev"]==""} {set lbl "HEAD"} {set rev "-v \"$rev\""} set finfo(${A}lbl,$ndx) "[shortNm $fn] ($Scm $lbl)" set finfo(${A}tmp,$ndx) "$cmd cat $rev \"$fn\"" } ClearCase { set cmd "cleartool" # is this NOT a Windows tool (why no append of .exe?) # list given file Dbg "exec $cmd ls -s \"$fn\"" catch {exec $cmd ls -s \"$fn\"} ctls # get the path name to file AND its (present?) revision info # (either CHECKEDOUT or a number) if {![regexp {(\S+)/([^/]+)$} $ctls na path checkedout]} { set msg "Couldn't parse ct ls output '$ctls'" break } # Compute the version PRIOR to the one FOUND if {$checkedout == "CHECKEDOUT" || $checkedout == 0} { if {$checkedout == 0} { set path [file dirname $path] } set pattern "create version \"($path/\[^/\]+)\"" } else { incr checkedout -1 set pattern "create version \"($path/$checkedout)\"" } # Search history of the file for the determined version on our branch Dbg "exec $cmd lshistory -last 50 \"$fn\"" catch {exec $cmd lshistory -last 50 \"$fn\"} ctlshistory set lines [split $ctlshistory "\n"] set prior "" foreach line $lines { if {[regexp $pattern $line na prior]} { # Point DIRECTLY at the requested file # However, make it APPEAR like it IS a tmpfile # (so we will deny invoking an editor later) set finfo(${A}lbl,$ndx) "[shortNm $fn] ($Scm $prior)" set finfo(${A}pth,$ndx) $prior set finfo(${A}tmp,$ndx) "" break } } if {$prior == ""} {set msg "Couldn't resolve $fn, gave up..."} } HG { append cmd "hg" $cmdsfx; # Mercurial support if {[set lbl $rev]==""} {set lbl "PARENT"} {set rev "-r$rev"} set finfo(${A}lbl,$ndx) "[shortNm $fn] ($Scm $lbl)" set finfo(${A}tmp,$ndx) "$cmd cat $rev \"$fn\"" } None { set msg "Did your preferred SCM system ($Scm) block file:\n" append msg " $fn\nfrom its intended SCM repository?" } default {set msg "File '$fn' is not part of a revision control system"} }} else { set msg "$Scm does not accept URL-based File specifications"} # If NO errs (and in 1st pairing) NOW is the time to actually GET the file # (even an ancestorfile if its required) if {$msg == ""} { if {[string length $finfo(${A}tmp,$ndx)] && $ndx < ("$A"=="" ? 3:2)} { watch-cursor "Accessing $finfo(${A}lbl,$ndx)" set msg [scm-chkget ${A}$ndx] restore-cursor } } # Note label for this file COULD be overridden (just NOT here) if {[info exists finfo(ulbl,$ndx)] && $finfo(ulbl,$ndx) != {}} { Dbg " User label: $finfo(ulbl,$ndx) OVERRIDES finfo(lbl,$ndx)" } # Report errors, but only abort if tool is NOT up and running if {"$msg" != ""} { if {$g(startPhase)} {popmsg "$msg"} {fatal-error "$msg"} return 1 } return 0 } proc is-repo-dir {trgnam dirname} { # check for trgnam directory in all parent directories set dirname [file normalize $dirname] set prevdir {} while {$dirname != $prevdir} { set chkDnam [file join $dirname $trgnam] if {[file isdirectory $chkDnam]} { return true } set prevdir $dirname set dirname [file dirname $dirname] } return false } proc is-git-repository {} { return [expr [catch {eval "exec git rev-parse --is-inside-work-tree"} err] == 0] } proc sccs-is-bk {} { set cmd [auto_execok "bk"] set result 0 if {[string length $cmd] > 0} { if {![catch {exec bk root} error]} { set result 1 } } return $result } ############################################################################### # Obtain an ordinary file # fn requested file name # ndx finfo array index to place data ('-' ndx implies Ancestor naming) # Returns: 0 Success # 1 Failed ############################################################################### proc get-file {fn ndx} { global g finfo # Ancestor files are stored into a slightly adjusted array element name if {$ndx < 0} {set A "a"; set ndx [expr {-1 * $ndx}]} {set A ""} set msg "" if {[file isfile $fn]} { set finfo(${A}lbl,$ndx) [shortNm [set finfo(${A}pth,$ndx) "$fn"]] } elseif {![file exist $fn]} { set msg "File '$fn' does not exist" } else { set msg "'$fn' exists, but is not a file" } # Report errors, but only abort if tool is NOT up and running if {"$msg" != ""} { if {$g(startPhase)} {popmsg "$msg"} {fatal-error "$msg"} return 1 } return 0 } ############################################################################### # Read the commandline (errors result in usage + termination) # Returns: =0 incomplete (requires interactive assistance) # >0 success (enough info SUPPLIED for at least 1 pairing to exist) ############################################################################### proc commandline {} { global g opts finfo argv argc set argindex 0 set lbls 0 set URLs [set pths [set revs 0]] ;# N.B> Ancestor data is NEVER 'counted' set ignRxs [llength $opts(ignoreRegexLnopt)] # Loop through argv, storing revision args in finfo(rev,[12]) and # filespec args in finfo(f,[12]). revs and pths are counters. # N.B> 'URLs' as a LOCAL variable serves a different purpose in EACH proc # you find it in: here it counts URLs that LACK a SPECIFIC Rev; # Other procs simply use it (locally) for THEIR distinctive purposes. while {$argindex < $argc} { set arg [lindex $argv $argindex] switch -regexp -- $arg { "^-h" - "^--help" { do-usage cline exit 0 } {^-a.*$} { # First, de-tangle the option value from the option flag # to get just the Ancestor "filename" if {[string length $arg] > 2} { set path [string range $arg 2 end]} { set path [lindex $argv [incr argindex]] } # Then identify if it actually is a URL (SVN based syntax) if {[regexp {^[^/:]+://[^/]+/.+?@?([0-9]+)?$} $path na rev]} { # Force set the Rev version (if it was supplied) if {"$rev" != ""} { set finfo(rev,0) "$rev" } # In any event, strip-off the version SYNTAX from the URL set path [string trimr "[string trimr "$arg" "$rev"]" "@"] } # Finally loading the Ancestor "filename" where it belongs set finfo(f,0) "$path" } {^-@.*$} { # First, de-tangle the option value from the option flag # to get just the Ancestor Rev data if {[string length $arg] > 2} { set rev [string range $arg 2 end]} { set rev [lindex $argv [incr argindex]] } # First to set this locks it in place, EXCEPT for a URL+Rev if {$finfo(rev,0) == ""} {set finfo(rev,0) $rev} } {^-[vr].*$} { # All 'rev' option(s) are ganged together here to share logic: # Cant just 'count and store' because it MAY be INTENDED to # backfill a PRE-existing URL Fspec that lacked specific # Rev data (using the pairing-of-args rules); but URLS have # ALREADY been Rev-counted (and we must not count it twice). # First, de-tangle the option value from the option flag if {[string length $arg] > 2} { set rev [string range $arg 2 end]} { set rev [lindex $argv [incr argindex]] } # Might THIS Rev PAIR with a PRIOR default-versioned URL? # # + Rev(s) CLAIM to exist (but COULD be URL-paired) # then + 2 Fspecs exist (need to check 1st one) if {$pths && [set i [min $revs 2]] && (($i == 2 && [regexp {://} $finfo(f,2)]) || ($i == 1 && [regexp {://} $finfo(f,1)]))} { if {$finfo(rev,$i) != ""} { set i [incr revs]} {incr URLs -1} } { set i [incr revs] } # PERMIT up to the 1st two Revs; though errors may COUNT more if {$i < 3} {set finfo(rev,$i) $rev} } "^-L$" { incr argindex incr lbls set finfo(ulbl,$lbls) [lindex $argv $argindex] } "^-L.*" { incr lbls set finfo(ulbl,$lbls) [string range $arg 2 end] } "^-conflict$" { set g(conflictset) 1 } "^-o$" { incr argindex set g(mergefile) [lindex $argv $argindex] } "^-o.*" { set g(mergefile) [string range $arg 2 end] } "^-u$" { # Ignore flag generated from "svn diff --diff-cmd=tkdiff" } "^-B$" { set opts(ignoreEmptyLn) 1 } "^-I$" { incr argindex lappend opts(ignoreRegexLnopt) [lindex $argv $argindex] } "^-I.*" { lappend opts(ignoreRegexLnopt) [string range $arg 2 end] } {^-[12]$} { set opts(predomMrg) [string range $arg end end] } "^-d.*" { # DbuG specs acummulate, but only 1st need be noted here if {!$g(debug)} { set g(debug) t ;# Activates 'Dbg' messaging, Ident logging Dbg "Running $g(name) $g(version)" } } "^-psn" { # Ignore the Carbon Process Serial Number set argv [lreplace $argv $argindex $argindex] incr argc -1 incr argindex } "^-" { append opts(diffcmd) " " [concat "$arg"] } default { # A URL is effectively a Rev, DESPITE an un-specified @Rev! # (due to implying its own inherent default value) # First identify if it REALLY is a URL (SVN based syntax) if {[regexp {^[^/:]+://[^/]+/.+?@?([0-9]+)?$} $arg na rev]} { incr pths # Next, if it HAS a Rev, ensure it remains bound TO this # URL (incase other Revs have ALREADY been enterred) if {"$rev" != ""} { if {$finfo(rev,2)==""} { set finfo(rev,[incr revs]) $finfo(rev,1) } {incr revs} set finfo(rev,$pths) "$rev" } else {incr URLs ; incr revs} # In any event, strip-off the version SYNTAX from the URL set path [string trimr "[string trimr "$arg" "$rev"]" "@"] # else its just a plain old Fspec; Just count and record } else { set path $arg ; incr pths } # PERMIT up to the 1st two Fspecs; though errors may COUNT more if {$pths < 3} {set finfo(f,$pths) $path} } } incr argindex } # Check for an overflow of revision and/or file args given. # (Command line syntax bounds checks) Dbg " $pths filespecs, $revs-$URLs revisions" if {$revs-$URLs > 2 || $pths > 2} { if {$pths > 2} { puts stderr "Error: specify at most 2 filespecs" } if {$revs-$URLs > 2} { puts stderr "Error: specify at most 2 revisions" } do-usage cline exit 1 } # Underflow is trickier - ZERO Fspecs *may* be legal given an appropriate # CWD and compliant SCM. Even ZERO revs can be OK if the user permits it. # # Basically this is all about AVOIDING "newDiff" (if requested) # when ZERO Fspec args (and possibly zero Revs) have been provided set g(scmDOsrch) 0 set g(scmPrefer) "$opts(scmPrefer)" ;# <-- Make the default 'active' if {!$pths} { # The automatic way out is a SINGLE, preferred, searchable SCM, with # either given Revs, -OR- the users REQUEST that searching is desired. # Otherwise it all loads into the dialog and the user can handle it # N.B> do not simplify logic: 'scmDOsrch' is NEEDED by 'assemble-args' # First, resolve which SIDE may have a viable SCM (if any) set scms [scm-detect "."] ;# (need only 'detect' once w/CWD for both) if {[set finfo(scm1) [scm-elect "$scms" [lindex $g(scmPrefer) 0]]] \ in $g(scmSrch)} {incr g(scmDOsrch) 1} if {[set finfo(scm2) [scm-elect "$scms" [lindex $g(scmPrefer) 1]]] \ in $g(scmSrch)} {incr g(scmDOsrch) 2} # Finally - check if we now have a DEFINITIVE choice ... # (if both SCMs are the same, it counts as just one) if {$g(scmDOsrch) != 3 \ || ("$finfo(scm1)" == "$finfo(scm2)" && [incr g(scmDOsrch) -1])} { # ... (and the Revs -OR- users OK to just go DO it) if {$g(scmDOsrch) && $opts(autoSrch) && !$revs} { incr revs ;# go STRAIGHT to processing (no dialog) } } # If revs is ZERO as of now, the dialog will be presented next #Dbg "DOsrch($g(scmDOsrch)) skipdialog($revs)" } # Notice certain imperative settings: # - mark merge file as INITIALLY known (thus triggering the merge window) # - turn on Regex line skipping *if* it was added here (else its a pref) if {$g(mergefile) != ""} {set g(mergefileset) 1} if {$ignRxs < [llength $opts(ignoreRegexLnopt)]} {set opts(ignoreRegexLn) 1} return [expr {$revs + $pths}] } ############################################################################### # Check provided filename to see if its leading portion can be SHORTENNED. # fn: candidate filename # rmv: the LEAD portion to be matched and removed (default is [pwd]) # rpl: what should take its place (default is NOTHING) # # USAGE NOTEs - # 1. 'rmv' is AUTOMATICALLY '/'-suffixed (to PREVENT any partial matching) # but is itself ONLY removed when 'rpl' is specified as EMPTY # 2. Accordingly, 'rpl' should NOT generally END with a '/' when specified # 3. The correct way to perform a tilde reduction is: # shortNm /some/usersHomeDir/rest/of/filename [glob ~] ~ # # Intent is to produce shorter NAMES of filenames in things like: # menu-items, msgs and labels # (RETURNS unchanged filename when modification is not possible) # # N.B> DO NOT USE if the return value COULD find its way to 'exec': # Invoked PGMs (notably Diff) DONT always natively accept 'tilde' names! ############################################################################### proc shortNm {fn {rmv {[pwd]}} {rpl {}}} { # N.B> +/- 1 game and '/' avoids a potential home-dir SUBSET naming mistake set ndx [string length [eval set lead $rmv]] if {[string equal -length [incr ndx] "$lead/" "$fn"]} { if {$rpl!=""} {incr ndx -1} return "$rpl[string range "$fn" $ndx end]"} else {return "$fn"} } ############################################################################### # Process the arguments, whether from the command line or from the dialog # Returns: >0 success (= number of file PAIRINGS that apparently exist) # (only the first of which has generally been already obtained) # =0 failure (can not continue) ############################################################################### proc assemble-args {} { global g opts finfo set O([set O(2) 1]) 2;# (just a simple meta-pgm 'O'ther identity value) # RE-establish how many files and revs we got from the GUI or commandline # (An AncestorFile - finfo slot ZERO - is NEVER part of the count) # However, a URL must count as BOTH (even w/o a Rev - due to IMPLIED dflts) # N.B> 'URL' here tracks WHICH slot(s) (L=1/R=2) contain a URL Fspec set URL [set revs [set pths 0]] foreach i [array names finfo {f,[12]}] { if {$finfo($i) != ""} { # This weirdness bumps the Rev cnt when a URL did NOT specify one # (because the ones that DID will be counted shortly) # and notes which slot (1, 2, or BOTH=3) a URL was enterred on if {[regexp {://} $finfo($i)]} { if {$URL} {set URL 3} {set URL [string index $i end]} if {$finfo([string map {f rev} $i]) == ""} {incr revs} } incr pths } } foreach i [array names finfo {rev,[12]}] {if {$finfo($i)!=""} {incr revs} } # Save any current DERIVED values (in case NEWLY produced ones fail) # and establish a catchall failure msg (should NEVER actually see it) set priorVals [array get finfo {[aptl]*[0-9]}] array unset finfo {[aptl]*[0-9]} set msg "Unexpected failure (internal error)" Dbg " Recovered $pths filespecs, $revs revisions" # The task here is to deal with trying to expand all GIVEN args into PAIRS # of things to compare, thus validating *syntactically* what should happen. # Note that SEMANTIC correctness (can we actually OBTAIN what is described) # will (mostly) occur later. # CURRENT argument basic ASSUMPTIONs - # - when NO SCM is involved, only LOCAL files will participate, possibly # aggregated by involving a Directory as one/both of the Filespecs. # - when an SCM is needed (because one or more revisions exist), we 1st # PRESUME the OTHER FILESPEC (if any) refers to some REAL (dir or file) # object which MAY be in the sandbox (or not), UNLESS its a URL. # - when only a single (or no) revision is provided, then some FILE (in # or out of the sandbox) will likely participate unless BOTH are URLs. # - when TWO revs are given, NO FILES from the sandbox are used (except # possibly for name generation); revisions ALWAYS create temp files FROM # the SCM, even if either revision were to MATCH that of the sandbox. # - finally, if NO ARGS are provided, CERTAIN capable SCM systems MAY # generate their OWN list of files AND revisions, PROVIDED the user has # authorized such action by SETTING the AutoSrch option. set cnt 0 ;# Track how many IMPLIED files ultimately are derived if {$g(conflictset)} { if {$revs == 0 && $pths == 1} { ################################################################# # tkdiff -conflict FILE (N.B> does NOT preclude a 3way) ################################################################# # Conflict files can come from multiple SCM toolsets, or even a # 'diff3 -m Mine [Ancestor] Yours' command. The names entered # into finfo are DERIVED from embedded MARKER lines inside it # (while the CONTENT is now in separate tmpfiles). set cnt [split-conflictfile "$finfo(f,1)" $cnt] } else { set msg "'-conflict' run can specify ONLY 1 filespec (we saw $pths)" } } else { set msg "you specified $pths filespec(s) and $revs revision(s)" if {$revs <= 2 && $pths == 0} { ################################################################# # tkdiff (inquiry or interactive) (simply NO input given) # -OR- # tkdiff -rREV ($CWD is) SCM sandbox # tkdiff -rREV1 -rREV2 (with 1 or 2 revisions) ################################################################# # Some SCMs can produce their OWN list of files 'known' to be # different; POSSIBLY with no input whatsoever. So detect the SCM # first, THEN (if it is one) let *it* try. All other cases lead # to error msgs (if revs were given). # Note that DETECTING the SCM was based on the current PROCESS dir # and that 'scmPrefer' used here is DERIVED from the preference if {$g(scmDOsrch)} { set Scm [lindex $g(scmPrefer) $g(scmDOsrch)-1] ;# VOTE first set Scm [scm-elect $finfo(scm$g(scmDOsrch)) $Scm] ;# then ELECT } else {set Scm [concat $g(scmPrefer)]};# <-- it WONT be searchable switch -glob -- "$Scm" { GIT { # N.B: An input syntax of '-r ' (or '-r " "') is the Git Index # If (cnt < 2), "msg" will be overwritten with reason why if {$opts(autoSrch) || $g(scmDOsrch)} { set cnt [inquire-git $revs msg] } {set msg "You denied access for $Scm to search for files"} } SVN { if {$opts(autoSrch) || $g(scmDOsrch)} { set cnt [inquire-svn $revs msg] } {set msg "You denied access for $Scm to search for files"} } CVS { if {$opts(autoSrch) || $g(scmDOsrch)} { set cnt [inquire-cvs $revs msg] } {set msg "You denied access for $Scm to search for files"} } "* *" { set msg "no searchable SCM was detected/designated\n" if {([lindex $Scm 0] != "" && [lindex $Scm 1] != "") \ && ([lindex $Scm 0] != "Auto" || [lindex $Scm 1] != "Auto")} { append msg " were your SCM settings '$Scm' at fault ?" } } default { if {"$Scm" != "" } { set msg "the $Scm SCM system needs at least 1 Fspec given" } { set msg "no SCM was detected for the current directory" } } } } elseif {$revs < 2 && $pths == 1} { ################################################################# # tkdiff FILESPEC (file in, dir at, URL .vs.) SCM sandbox # tkdiff -rREV FILESPEC with or without a revision) ################################################################# set f(1) "$finfo(f,1)" ; set f(2) "$finfo(f,2)" set r(1) "$finfo(rev,1)" ; set r(2) "$finfo(rev,2)" # URL 'side' is determined by which arg was first: Fspec or Rev # Any other arg syntax is ALWAYS Left =SCM(@REV) and Right =File if {$URL} { if {$r($URL) == $r($O($URL))} { set msg "There is NO point in comparing a file to itself" } elseif {[get-file-rev "$f($O($URL))" $O($URL) "$r($O($URL))"]} { array unset finfo "\[ptl]*,$O($URL)" } elseif {[get-file-rev "$f($URL)" $URL "$r($URL)"]} { array unset finfo "\[ptl]*,\[12]" } else {set cnt 2} } elseif {[file isdirectory $f(1)]} { foreach P [glob -nocomplain -directory $f(1) -types f *] { set f(2) "[file join $f(1) [file tail $P]]" if {[get-file-rev "$f(2)" [incr cnt] "$r(1)"]} { array unset finfo "\[ptl]*,$cnt" ; incr cnt -1 } elseif {[get-file "$f(2)" [incr cnt]]} { array unset finfo "\[ptl]*,$cnt" array unset finfo "\[ptl]*,[incr cnt -1]" incr cnt -1 } } } else { if {[get-file-rev "$f(1)" [incr cnt] "$r(1)"]} { array unset finfo "\[ptl]*,1" ; incr cnt -1 } elseif {[get-file "$f(1)" [incr cnt]]} { array unset finfo "\[ptl]*,\[12]" } } } elseif {$revs == 2 && $pths == 1} { ################################################################# # tkdiff -rREV1 -rREV2 FILESPEC (file in, dir at) SCM sandbox ################################################################# set r(1) "$finfo(rev,1)" set r(2) "$finfo(rev,2)" if {[file isdirectory [set P $finfo(f,1)]]} { foreach f(2) [glob -nocomplain -directory $P -types f *] { set f(1) "[file join $P [file tail $f(2)]]" if {[get-file-rev "$f(1)" [incr cnt] "$r(1)"]} { array unset finfo "\[ptl]*,$cnt" ; incr cnt -1 } elseif {[get-file-rev "$f(2)" [incr cnt] "$r(2)"]} { array unset finfo "\[ptl]*,$cnt" array unset finfo "\[ptl]*,[incr cnt -1]" incr cnt -1 } } } else { if {[get-file-rev "$P" [incr cnt] "$r(1)"]} { array unset finfo "\[ptl]*,1" ; incr cnt -1 } elseif {[get-file-rev "$P" [incr cnt] "$r(2)"]} { array unset finfo "\[ptl]*,\[12]" } } } elseif {$revs == 0 && $pths == 2} { ############################################################ # tkdiff FILESPEC1 FILESPEC2 (dirs, files or mixed) ############################################################ set f(1) $finfo(f,1) set f(2) $finfo(f,2) # One, the other, or both may be directories # Regardless, the same FILE name must exist in EACH to be paired if {[file isdirectory $f(1)] && [file isdirectory $f(2)]} { foreach P [glob -nocomplain -directory $f(1) -types f *] { #N.B. "file isfile xxx" thankfully WON'T fault OS softlinks if {[file isfile [set F [file join $f(2) [file tail $P]]]]}\ { set finfo(lbl,[incr cnt]) \ [shortNm [set finfo(pth,$cnt) $P]] set finfo(lbl,[incr cnt]) \ [shortNm [set finfo(pth,$cnt) $F]] } } if {$cnt < 2} { set msg "Given directories have NO filenames in common" } } elseif {[file isdirectory $f([set i 1])] || [file isdirectory $f([set i 2])]} { if {![get-file [file join $f($i) [file tail $f($O($i))]] $i]} { incr cnt} else { set msg "Searched file $f($O($i)) non-existant in: $f($i)" } if {![get-file "$f($O($i))" $O($i)]} {incr cnt} } else { # Otherwise they are just files if {![get-file "$f(1)" 1]} {incr cnt} if {![get-file "$f(2)" 2]} {incr cnt} } } elseif {$revs > 0 && $pths == 2} { ################################################################# # tkdiff -rREV1 FILESPEC1 (file in, dir at, URL) SCM sandbox # (+) [-rREV2] FILESPEC2 (same or distinct) SCM sandbox # (can compare ACROSS a branch/WC boundary or distinct SCMs) ################################################################# set f(1) $finfo(f,1) ; set r(1) "$finfo(rev,1)" set f(2) $finfo(f,2) ; set r(2) "$finfo(rev,2)" if {[file isdirectory $f(1)] && [file isdirectory $f(2)]} { foreach P [glob -nocomplain -directory $f(1) -types f *] { if {![file isfile [set fn2 [file join $f(2) $P]]]} { continue} {set fn1 [file join $f(1) $P]} if {[get-file-rev "$fn1" [incr cnt] "$r(1)"]} { array unset finfo "\[ptl]*,$cnt" ; incr cnt -1 } elseif {[get-file-rev "$fn2" [incr cnt] "$r(2)"]} { array unset finfo "\[ptl]*,$cnt" array unset finfo "\[ptl]*,[incr cnt -1]" incr cnt -1 } } if {$cnt < 2} { set msg "Provided Dirs have NO filename in common" } } elseif {[file isdirectory $f([set i 1])] || [file isdirectory $f([set i 2])]} { set P "[file join $f($i) [file tail $f($O($i))]]" if {[get-file-rev "$P" [incr cnt] "$r($i)"]} { array unset finfo "\[ptl]*,$cnt" ; incr cnt -1 } elseif {[get-file-rev "$f($O($i))" [incr cnt] "$r($O($i))"]} { array unset finfo "\[ptl]*,$cnt" array unset finfo "\[ptl]*,[incr cnt -1]" ; incr cnt -1 } } else { if {(($URL&1) || $r(1)!="") && [get-file-rev "$f(1)" [incr cnt] "$r(1)"]} { array unset finfo "\[ptl]*,1" ; incr cnt -1 } elseif {!($URL&1) && [get-file "$f(1)" [incr cnt]]} { array unset finfo "\[ptl]*,1" ; incr cnt -1 } if {(($URL&2) || $r(2)!="") && [get-file-rev "$f(2)" [incr cnt] "$r(2)"]} { array unset finfo "\[ptl]*,\[12]" ; incr cnt -2 } elseif {!($URL&2) && [get-file "$f(2)" [incr cnt]]} { array unset finfo "\[ptl]*,\[12]" ; incr cnt -2 } } } } Dbg "Final: $revs revs $pths filespecs -> $cnt/2 pairings" if {$cnt < 2} { if {[winfo exists .toolbar]} { popmsg "Error: $msg" do-usage gui tkwait window .usage } else { puts stderr "Error: $msg" do-usage cline } # Restore PRIOR values to finfo array unset finfo {[aptl]*[0-9]} array set finfo $priorVals } else { set finfo(fCurpair) 1 set finfo(fPairs) [expr {$cnt / 2}] if {[set P $finfo(f,0)] != {}} { # The USER may only specify a 3way when its a SINGLE comparison # Otherwise we silently erase their attempt if {$cnt == 2} { # Unlike other files, Ancestors can ONLY come from an SCM when # a rev is given (because DEFAULTING it to the most recent # check-in defeats its purpose) (?? but what about 'BASE' ??) if {[set r0 $finfo(rev,0)] != ""} { if {[get-file-rev "$P" -$finfo(fCurpair) "$r0"]} { array unset finfo "a\[ptl]*,1" } } elseif {[get-file "$P" -$finfo(fCurpair)]} { array unset finfo "a\[ptl]*,1" } } else { lassign {} finfo(f,0) finfo(rev,0) } } } return $finfo(fPairs) } ############################################################################### # Align window label decorations to the CURRENT input file pairing ############################################################################### proc alignDecor {pairnum} { global g w finfo # Establish if 3way mode is NOW active and what file indices are in use set g(is3way) [info exists finfo(albl,$pairnum)] Dbg "is3way($g(is3way))" set ndx(1) [set ndx(2) [expr {$pairnum * 2}]] incr ndx(1) -1 set finfo(title) \ "[file tail $finfo(lbl,$ndx(1))] .vs. [file tail $finfo(lbl,$ndx(2))]" # Set file labels (possibly overridden) and a Tooltip for REAL files foreach {LR n} {Left 1 Right 2} { if {[info exists finfo(ulbl,$ndx($n))] && $finfo(ulbl,$ndx($n)) !={}} { set finfo(lbl,$LR) $finfo(ulbl,$ndx($n)) ;# Override lbl display } else {set finfo(lbl,$LR) $finfo(lbl,$ndx($n))} if {![info exists finfo(tmp,$ndx($n))]} { # (N.B> Tip data will ALSO be used by report generation heading) set g(tooltip,${LR}Label) "{$finfo(pth,$ndx($n))\n" append g(tooltip,${LR}Label) \ "[clock format [file mtime $finfo(pth,$ndx($n))]]}" } { set g(tooltip,${LR}Label) {}} set_tooltips $w(${LR}Label) "$g(tooltip,${LR}Label)" } # Add/Remove the Ancestor indicator (and its tooltip) as needed if {$g(is3way)} { grid $w(AncfLabel) -row 0 -column 1 if {![info exists finfo(atmp,$pairnum)]} { set tipdata "{$finfo(apth,$pairnum)\n" append tipdata "[clock format [file mtime $finfo(apth,$pairnum)]]}" } { set tipdata "{$finfo(albl,$pairnum)}"} set_tooltips $w(AncfLabel) "$tipdata" } else { set_tooltips $w(AncfLabel) {} grid forget $w(AncfLabel) } # Unlock a preset mergefile name if the CURRENT pairing COULD be arbitrary if {$finfo(fPairs) > 1} {set g(mergefileset) 0} # Guess the best 'mergefile' name for the CURRENT pairing (if not preset) if {! $g(mergefileset)} { # If BOTH are tmpfiles, lets go with just the file itself in the CWD... if {[info exist finfo(tmp,$ndx(1))]&&[info exist finfo(tmp,$ndx(2))]} { set rootname [file rootname [file tail $finfo(pth,$ndx(1))]] set suffix [file extension $finfo(pth,$ndx(1))] } else { # ...or lets pair it to the NON-tempfile location (Left preferred) if {[info exists finfo(tmp,$ndx(1))]} {set i 2} {set i 1} set rootname [file rootname $finfo(pth,$ndx($i))] set suffix [file extension $finfo(pth,$ndx($i))] } set g(mergefile) [file join [pwd] "${rootname}-merge$suffix"] } Dbg "MergeFileSet($g(mergefileset)): $g(mergefile)" wm title . "$finfo(title) - $g(name) $g(version)" return 0 } ############################################################################### # Request git to supply relevant target argument(s) ############################################################################### proc inquire-git {revs msgRet} { global finfo upvar $msgRet MSG # Git diff requires 0-2 commit-ish "somethings" (hash, HEAD, etc...) # # As such, we expect those args to come thru as 'revs'; 'pths' could # only be useful to LIMIT the list being constructed (if we allowed them). # Git differs from most SCMs in that it has an intermediate "pocket" # (called the 'index', or 'stage') BETWEEN the working copy (WC) and a # bona-fide "commit" (aka revision). Therefore while the nominal mapping # is: # 'revs': # 0 = HEAD -> WC # 1 = rev -> WC # 2 = revA -> revB # use of a BLANK rev (" ") denotes the Index. Everything else SHOULD be # handled by "git rev-parse" (tags/hashes/branches/expressions/etc.) # Actual filesys entities are handled via "get-file-rev" (NOT by this proc) # # However, WE are responsible for mapping the BLANK rev to the --staged # keyword required to make "git diff" actually access the Index. set cmit(2) [set rev(2) ""] if {$revs == 0} { # Sets up HEAD -> WC set cmit(1) [set rev(1) "HEAD"] } elseif {$revs <= 2} { # Sets up (R1 or Index) -> (WC or Index or R2) if {"" == [string trim [set cmit(1) [set rev(1) $finfo(rev,1)]]]} { set cmit(1) "--staged" } if {$revs == 2} { # Sets up R1 -> R2 (but just NOT Index -> Index)!!! if {"" == [string trim [set cmit(2) [set rev(2) $finfo(rev,2)]]]} { if {"--staged" != $cmit(1)} {set cmit(2) "--staged"} { set MSG "BOTH revisions cannot specify the Git Index" return 0 ;# (Would've resulted in Index -> WC) } } } } # NORMALLY we would only extract the first pairing and simply RECORD # the others for later processing...but Git is a local-access SCM, # thus NO 'watch-cursor' call for latency - just go DO IT right now... # # Ask Git which files ACTUALLY differ between the given endpoint(s) # (but limit it to those files seemingly modified - NO add/del) set cmd "git diff --diff-filter=M --name-only $cmit(1) $cmit(2)" lassign [run-command $cmd] gitOUT gitERR gitRC if {$gitRC != 0 || $gitOUT == ""} { if {$gitRC == 0} { set MSG "Git Diff shows NO output using args: $cmit(1) $cmit(2)" } else {set MSG "Git Diff FAILED:\n$gitERR"} return 0 } set git_root [exec git rev-parse --show-toplevel] set ndx 0 foreach file [split $gitOUT "\n"] { # Ordinarily, 2-Revs would mean no possible WC interaction ... # But if either referred to the Index, then we need to check it # # Look for an "unmerged" situation (only shows up in the Index) # Git-assigned tag #s are: 1:ancestor 2:ours 3:theirs # (N.B> but unknown if they will extract here in that order) if {($revs < 2 || $cmit(1) == "--staged" || $cmit(2) == "--staged") \ && (1< [llength [set xx [split [exec git ls-files -s $file] "\n"]]])} { foreach i {3 2 1} { # Process each given item (in theirs/ours/ancestor order) foreach Gtag $xx { if {$i == [lindex $Gtag end-1]} {break} } # Label the pieces and ... if {$i > 1} { set finfo(pth,[incr ndx]) [set f [tmpfile "git_$i"]] set finfo(tmp,$ndx) "" set finfo(lbl,$ndx) "[shortNm $file] (GIT Cflct-" if {$i == 2} { append finfo(lbl,$ndx) "ours)" } \ else { append finfo(lbl,$ndx) "theirs)" } } else { set finfo(apth,[expr {$ndx/2}]) [set f [tmpfile "tg_$i"]] set finfo(albl,[expr {$ndx/2}]) "Ancestor (GIT Cflct)" set finfo(atmp,[expr {$ndx/2}]) "" } # ... grab the file content using its SHA1 id set cmd "git cat-file blob [lindex $Gtag end-2]" lassign [run-command $cmd $f] na gitERR gitRC # BUT - erase it ALL if ANY of it fails if {$gitRC} { set MSG "Git couldn't extract Conflict item($i): $file\n" append MSG $gitERR if {$i == 1} {array unset finfo "a*,[expr {$ndx/2}]"} if {$i <= 2} {array unset finfo "\[ptl]*,$ndx"} if {$i < 3} {incr ndx -1} if {$i <= 3} {array unset finfo "\[ptl]*,$ndx"; incr ndx -1} Dbg "$MSG" } } continue } # Otherwise its (supposedly) a plain old difference foreach i {1 2} { incr ndx if {$rev($i) != ""} { if {" " == [string index "$rev($i)" 0]} { set finfo(lbl,$ndx) "[shortNm $file] (Git$cmit($i))" } { set finfo(lbl,$ndx) "[shortNm $file] (Git $rev($i))"} # Git is a "local-machine" access method (no latency) so doing # them ALL right now should not be a burden. # If that proves wrong, THIS is where to fix it. set finfo(pth,$ndx) [tmpfile "tkd__[file tail $file]"] set finfo(tmp,$ndx) "" set cmd "git show $rev($i):$file" lassign [run-command $cmd $finfo(pth,$ndx)] na gitERR gitRC if {$gitRC} { if [string match "*exists on disk*" $gitERR] { # (the file simply is not *from* the requested 'rev') # Maybe it is an uncommitted (yet staged) file ? # Action: do nothing, let the tmp file remain empty. # This will end up as looking like an 'add' or 'del' # depending on which rev (1 or 2) could not find it. #} elseif [string match "*Invalid object name*" $gitERR] { # This used to just 'return 0'...but why single it out ? } else { # Instead, we just let it fall into this catchall, # and ensure that the PAIR OF FILES gets skipped... # NOT just the one that failed. Note that MSG is only # seen when NO pairs remain & TkDiff subsequently bails set MSG "FAILED: 'git show $rev($i):$file':\n$gitERR" if {$i == 1} {incr ndx -1; break} {incr ndx -2} Dbg "$MSG" } } } else { # Just point at the REAL 'working copy' file (allows editting) set finfo(lbl,$ndx) "[shortNm $file] (Git--WC)" set finfo(pth,$ndx) $git_root/$file } } } return $ndx } ############################################################################### # Request svn to supply relevant target argument(s) ############################################################################### proc inquire-svn {revs msgRet} { global finfo upvar $msgRet MSG # 'svn diff --summarize' tells us WHAT changed across a range of revisions # # rev is what we will tell svn cat to access # cmit is how we express the range to 'svn diff' set cmit(2) [set rev(2) ""] # This could take some time, so let user know we are busy watch-cursor "Inquiring of SVN for files..." if {$revs == 0} { # Sets up BASE -> WC set cmit(1) [set rev(1) "BASE"] } elseif {$revs <= 2} { # Sets up R1 -> (WC or R2) set cmit(1) [set rev(1) $finfo(rev,1)] if {$revs == 2} { # Finish seting up R1 -> R2 set cmit(2) ":[set rev(2) $finfo(rev,2)]" } } # Ask Svn which items got committed between the given endpoint(s) # do we need/want "--depth files" ??? # N.B> this might get messy with URL/PEG/date notations!!! set cmd "svn diff --summarize -r $cmit(1)$cmit(2)" lassign [run-command $cmd] svnOUT svnERR svnRC if {$svnRC || $svnOUT == ""} { if {$svnRC == 0} { set MSG "Svn diff shows NO output using rev: $cmit(1)$cmit(2)" } else {set MSG "Svn diff FAILED:\n$svnERR"} return 0 } # Expected output form should look like lines of: # "flgs filename" # (indices) 0-------7 8---------> # # where flgs can be: # D -deleted # A -added # M -modified # xM -(2nd M) properties modified # Note, "svn diff --summarize" unfortunately reports a CONFLICTED file # as 'M' as well, so we need to analyze a bit further # (because diffing of the embedded 'markers' is not very usefull) set ndx 0 foreach ln [split $svnOUT "\n"] { if {[lindex $ln 0] eq "M"} { set file [string range $ln 8 end] # If *is* a CONFLICTed file, split it up and store the finfo data if {$revs < 2 && [string match "C*" [exec svn status -q $file]]} { # SVN gives us a couple ways to go: # We COULD split-up the conflicted file, or simply GRAB the 3 # files that it stores as "extra" files for us - we will # try the latter (provided all 3 exist), else... if {[file exists $file.mine] \ && 2 == [llength [set Flist [glob -path $file .r*]]]} { # So we have 3 files (2 w/distinct Revs, the EARLIER # of which IS the ancestor) - assign them accordingly # First, parse out the two Rev values in the filenames set x [string length $file] set r0 [string replace [lindex $Flist 0] 0 $x+1 {}] set r1 [string replace [lindex $Flist 1] 0 $x+1 {}] # Then attach them ALL into finfo (as Edittable) foreach x "$file.r[max $r0 $r1] $file.mine" { set finfo(pth,[incr ndx]) "$x" set finfo(lbl,$ndx) "[shortNm $x] (SVN Cflct-" if {$ndx & 1} { append finfo(lbl,$ndx) "theirs)" } \ else { append finfo(lbl,$ndx) "mine)" } } set finfo(apth,[expr $ndx/2]) $file.r[min $r0 $r1] set finfo(albl,[expr $ndx/2]) "[shortNm $x] (SVN Ancestor)" } else {set ndx [split-conflictfile $file $ndx SVN]} continue } # otherwise its just plain old difference foreach i {1 2} { incr ndx if {"" != $rev($i)} { if {[get-file-rev $file $ndx $rev($i) SVN]} { if {$i == 1} {incr ndx -1; break} {incr ndx -2} } } else { # Just point at REAL 'working copy' files (allows editting) set finfo(lbl,$ndx) "[shortNm $file] (SVN--WC)" set finfo(pth,$ndx) $file } } } } restore-cursor return $ndx } ############################################################################### # Request cvs to supply relevant target argument(s) ############################################################################### proc inquire-cvs {revs msgRet} { global finfo upvar $msgRet MSG # 'cvs diff --brief' tells us what changed # # rev is what we will tell cvs update -p to access # cmit is how we express the range to 'cvs diff' set cmit(2) [set rev(2) ""] # This could take some time, so let user know we are busy watch-cursor "Inquiring of CVS for files..." if {$revs == 0} { # Sets up BASE -> WC set cmit(1) [set rev(1) "BASE"] } elseif {$revs <= 2} { # Sets up R1 -> (WC or R2) set cmit(1) [set rev(1) $finfo(rev,1)] if {$revs == 2} { # Finish seting up R1 -> R2 set cmit(2) " -r [set rev(2) $finfo(rev,2)]" } } # Ask CVS what changed between the given endpoint(s) set outfile [tmpfile "cvsout" 1] set cmd "cvs diff -l --brief -r $cmit(1)$cmit(2)" lassign [run-command $cmd $outfile] na cvsERR cvsRC # cvsRC can be non-zero in many cases, # eg.: if a file doesn't have one of the revs. # Thus it isn't very meaningful or helpfull here; however, # cvsERR should at least contain "cvs diff: Diffing ." regardless. # Yet in the empty case, cvsRC is then zero (rather confusing). # Due in part to these issues (and what TCL presumes about errors) we were # thus forced to place the cmd output into a file, to AVOID Tcl replacing # it (in cvsOUT) with its OWN error msgs. # SO - we rewrite cvsOUT FROM that file to SEE the case when it's empty, # and we will deduce Success (or not) out of the messaging provided set fp [open $outfile r] set cvsOUT [read $fp] close $fp file delete $outfile if {[string match {*Diffing*} $cvsERR] } { if {$cvsOUT == ""} { set MSG "CVS diff shows NO output using -r $cmit(1)$cmit(2)" return 0 } } # Expected output form will look like: # Index: File2.txt # =================================================================== # RCS file: /home/userid/path-into-repository/File2.txt,v # retrieving revision 1.5 # diff --brief -r1.5 File2.txt # Files /var/tmp/cvsdBUe0v and File2.txt differ # cvs diff: File3.txt was removed, no comparison available # cvs diff: FileAdd.txt is a new entry, no comparison available # Index: Ftrunk.txt # =================================================================== # RCS file: /home/userid/path-into-repository/Ftrunk.txt,v # retrieving revision 1.5 # diff --brief -r1.5 Ftrunk.txt # Files /var/tmp/cvs3Wrp6F and Ftrunk.txt differ # Note, cvs diff --brief doesn't report a conflicted file differently, and # cvs update -p will throw an error (unlike svn cat -p) making identifying # such files imperative - we also need its Revision (to locate an ancestor) # - UNLESS 2 Revs were provided (as that precludes using ANY WC files) set ndx 0 foreach ln [split $cvsOUT "\n"] { if {[string match "Index: *" $ln]} { # Grab the filename ... set fn [lindex $ln 1] set Cflct 0 ;# ... then check for a CONFLICTed file (presumed: NO) if {$revs < 2} { # Sadly, CVS does not provide RELATIVE revision references # (cant ask for 'parent' Rev of a file) so are forced to ask for # a 'cvs status' to both check for CONFLICT and GET its revision # THEN simulate a 'parent' conversion ourselves (subtract 0.1) foreach ln [split [exec cvs status $fn] "\n"] { if {!$Cflct && [string match "*Unresolved Conflict" $ln]} { set Cflct 1 } \ elseif {$Cflct && [string match "*Working rev*" $ln]} { # We want the last digits (Cf) of its revision value (Cr) set Cflct [lindex [set Cr [split [lindex $ln 2] "."]] end] lset Cr {end} [incr Cflct -1] ;# Compute PARENT Revision! break } } } # If *is* a CONFLICTed file, split it up and store as finfo data if {$Cflct} { set ndx [split-conflictfile $fn $ndx CVS] # OK - When CVS conflicts a file, it ALSO plants the prior # data as a hidden file in the WC - THAT is *ALMOST* our # ancestor - actually its the ancestor PLUS the users mods # (what existed just BEFORE the "update" ran). We COULD go # get the REAL ancestor, but this may be good enough ... # Grab it if it exists if {[file exists [set Afn ".#$fn.[join $Cr "."]"]]} { set finfo(apth,[expr {$ndx / 2}]) "$Afn" set finfo(albl,[expr {$ndx / 2}]) "[shortNm $Afn] (CVS Cflct)" } # (some CVS admins MAY have set up processes to delete it # after a few days wait time - perhaps THAT is when we # should try extracting the REAL one?) continue } # otherwise its a plain old difference foreach i {1 2} { incr ndx if {"" != $rev($i)} { if {[get-file-rev $fn $ndx $rev($i) CVS]} { if {$i == 1} {incr ndx -1; break} {incr ndx -2} } } else { # Just point at REAL 'working copy' files (allows editing) set finfo(lbl,$ndx) "[shortNm $fn] (CVS--WC)" set finfo(pth,$ndx) $fn } } } } restore-cursor return $ndx } ############################################################################### # Set up the display ############################################################################### proc create-display {} { global g w pref opts tmpopts # these are the four major areas of the GUI: # menubar - the menubar (duh) # toolbar - the toolbar (duh, again) # client - the area with the text widgets and the graphical map # status - a bottom status line # 'identify' major frames/windows and store them in a global array # # Status window MAY have been pre-built due to excessive network latency # If so, re-hide it until we can buildout the remainder of the display ... # Otherwise its ALREADY hidden, just build it along with everything else if {[set prebuilt [winfo exists .status]]} { wm withdraw . } { set w(status) .status } set w(client) .client set w(menubar) .menubar set w(toolbar) .toolbar set w(popupMenu) .popupMenu set w(merge) .merge # 'identify' other windows that conditionally MAY exist later... set w(srch) .srch set w(prefs) .pref set w(scDialog) .scDialog # now, simply build all the REQUIRED pieces build-toolbar build-client build-menus if {!$prebuilt} { build-status } build-merge frame .separator1 -height 2 -borderwidth 2 -relief groove frame .separator2 -height 2 -borderwidth 2 -relief groove # Now fit it all together... # Note this effectively "declares" the remaining 'pack'er cavity # to be just BELOW the client, but ABOVE the status bar. # (EXACTLY where DbgUI will appear if/when sourced in !!) # DbgUI is a standalone bind-investigation custom debugging tool . configure -menu $w(menubar) pack $w(toolbar) -side top -fill x -expand n pack .separator1 -side top -fill x -expand n pack .separator2 -side top -fill x -expand n pack $w(client) -side top -fill both -expand y if {!$prebuilt} { pack $w(status) -side bottom -fill x -expand n } # APPLY the users preferences by calling the proc that gets invoked when # the user presses "Apply" from the preferences window. That proc uses a # global variable ("tmpopts") which would ordinarily have the NEW values # from the dialog. # Since we haven't USED the dialog, populate this array DIRECTLY ! # (we simply need it to ENSURE these settings are what is "in effect") array set tmpopts [array get opts] prefapply # Make sure temporary files get deleted #bind . {del-tmp} # Create static list of Text widget actions that, when configure'ing, # will NOT alter the display height of any text line (a plot speedup) set g(benign) { mark bbox cget compare count debug dlineinfo \ dump get index peer search xview } # Then arrange for line numbers to be redrawn when just about anything # happens to ANY of our text widgets programatically. # This runs much faster than you might think. trace add exec $w(LeftText) leave [list plot-line-info Left] trace add exec $w(RightText) leave [list plot-line-info Right] trace add exec $w(mergeText) leave [list plot-merge-info] bind $w(LeftText) [list plot-line-info Left] bind $w(RightText) [list plot-line-info Right] bind $w(mergeText) [list plot-merge-info] # Lastly, we make any wheel scrolling over the Info windows work # (even though they themselves dont ACTUALLY scroll - they repaint) # 'eval' simply eliminates vars from within the quoted bind-scripts # (???- found no way to just FORWARD the event to the Text widget) foreach side {Left Right merge} { foreach evt {Button-4 Button-5 Shift-Button-4 Shift-Button-5} { eval bind $w(${side}Info) <$evt> \ "{event generate $w(${side}Text) <$evt> -when head}" } foreach evt {MouseWheel Shift-MouseWheel} { eval bind $w(${side}Info) <$evt> \ "{event generate $w(${side}Text) <$evt> -delta %D -when head}" } } # Watch for the user to toggle scrollbar syncing # (we want to make sure they sync up immediately) trace add var opts(syncscroll) write toggleSyncScroll # Attach all remaining bindings (mostly User-assigned shortcut HOTkeys) setBinds $w(LeftText) $w(LeftInfo) $w(RightText) $w(RightInfo) \ $w(mergeText) $w(mergeInfo) $w(BottomText) $w(merge) {.} # ...and ADVERTISE such hotkeys into any pertinent MENU entries foreach key [array names pref {[gnm][ear][nvg]*}] { if {[info exists w(Accel,$key)]} { foreach {mnu idx} $w(Accel,$key) { $mnu entryconfigure $idx -accelerator "$opts($key)" } } } wm deiconify . focus -force $w(RightText) update idletasks # Need this to make our L/R 'pane'-resize emulation behave logically # (cant have it appealing to its Toplevel for MORE space) grid propagate $w(client) false # This may appear even stranger: # Now that the main window has been built AND preferences applied, there # is an EXCELLENT chance that its REQUESTED size has been curtailed by # forcing a geometry modification onto it, keeping it from being screen # clipped on its intial display. # It is THOSE dimensions we want the newly built merge window to # center above. So we will use an unusual cmd syntax into centerWindow to # possibly override the main window dimensions, while ALLOWING the actual # w(merge) size to be picked up. # But first - we need to let the main window actually FINISH with its # ation (or even WE wont get the correct size...) # Luckily, 'centerWindow' brackets its action BETWEEN 2 'update' calls... scan [winfo geometry .] "%dx%d" W H centerWindow $w(merge) "0 0 $W $H" } ############################################################################### # when the user changes the "sync scrollbars" option, we want to # sync up the left scrollbar with the right if they turn the option on ############################################################################### proc toggleSyncScroll {args} { global w opts if {$opts(syncscroll) == 1} { set yview [$w(RightText) yview] vscroll-sync 2 [lindex $yview 0] [lindex $yview 1] } } ############################################################################### # show the popup menu, reconfiguring some entries based on where user clicked # (notably - over the MAP window becomes somewhat Left/Right ambiguous) ############################################################################### proc show-popupMenu {x y} { global g w set win [winfo containing $x $y] if {$win == $w(LeftText) || $win == $w(LeftInfo) || $win == $w(RightText) || $win == $w(RightInfo)} { # Turn these back ON (as they MAY have been turned off last time) if {$g(count)} { $w(popupMenu) entryconfigure "Find Nearest*" -state normal } $w(popupMenu) entryconfigure "Edit*" -state normal # Ensure g(activeWindow) is correct for USE by above two entries if {$win == $w(LeftText) || $win == $w(LeftInfo)} { $w(popupMenu) configure -title "File 1" set g(activeWindow) $w(LeftText) } else { $w(popupMenu) configure -title "File 2" set g(activeWindow) $w(RightText) } } else { # Turn these OFF in case we are NOT over the Text (or its Info) window # (no way to know which SIDE they should apply to) $w(popupMenu) entryconfigure "Find Nearest*" -state disabled $w(popupMenu) entryconfigure "Edit*" -state disabled } # Only allow clipboard copy if the primary selection is ours to begin with # AND is still PRESENTLY selected (as opposed to being FORMERLY selected) if {[selection own] == "$win" && ![catch "$win index sel.first"]} { set selstatus "normal"} {set selstatus "disabled"} $w(popupMenu) entryconfigure "Copy Selection" -state $selstatus tk_popup $w(popupMenu) $x $y } ############################################################################### # Load a different file pair of a multi-file diff ############################################################################### proc multiFileMenu {command index} { global w opts finfo Dbg "multiFileMenu ($command $index) -> $finfo(fCurpair)" if {$finfo(fPairs) <= 1} {return} set OK 1 switch -- $command { prev { if {$finfo(fCurpair) > 1} { incr finfo(fCurpair) -1 } else {set OK 0} } next { if {$finfo(fCurpair) < $finfo(fPairs)} { incr finfo(fCurpair) } else {set OK 0} } jump { set finfo(fCurpair) $index } } if {$OK} { do-diff ; update-display } } ############################################################################### # Resize the text windows relative to each other (ie. NET size chg = ZERO) ############################################################################### proc pane-drag {win x} { set relX [expr $x - [winfo rootx $win]] set maxX [winfo width $win] set frac [expr int((double($relX) / $maxX) * 100)] # LIMIT exchange of traded window real estate to the MIDDLE 90% set L [set frac [min 95 [max $frac 5]]] set R [expr 100 - $frac] grid columnconfigure $win 0 -weight $L grid columnconfigure $win 2 -weight $R #Dbg " new L/R ratio: $L $R" } ############################################################################### # build the main client display (text widgets, scrollbars, that sort of fluff) ############################################################################### proc build-client {} { global g w opts frame $w(client) -bd 2 -relief flat # set up global variables to reference the widgets, so # we don't have to use hardcoded widget paths elsewhere # in the code # # Text - holds the text of the file # Info - holds meta-data ABOUT 'Text': LineNums, Changebars, etc # VSB - vertical scrollbar # HSB - horizontal scrollbar # Label - label to hold the name of the file set w(LeftText) $w(client).left.text set w(LeftInfo) $w(client).left.info set w(LeftHSB) $w(client).left.hsb set w(LeftLabel) $w(client).leftlabel set w(AncfLabel) $w(client).ancFile set w(RightText) $w(client).right.text set w(RightInfo) $w(client).right.info set w(RightHSB) $w(client).right.hsb set w(RightLabel) $w(client).rightlabel set w(BottomText) $w(client).bottomtext set w(map) $w(client).map set w(mapCanvas) $w(map).canvas # May eventually need this for a 3way diff (see 'alignDecor' for details) button $w(AncfLabel) -bd 0 -image ancfImg -command { simpleEd open $finfo(apth,$finfo(fCurpair)) ro \ fg [$w(mergeText) cget -fg] \ bg [$w(mergeText) cget -bg] \ title "$finfo(albl,$finfo(fCurpair)) - Ancestor" } # We create several widgets twice; once for Left and again for Right # # First up, the labels... # N.B> DO NOT set a WIDTH size on these, we simply want them to # use whatever space is given to them by virtue of the TxtWdgs # they will be positioned above (ie. in the same grid-mgr COLUMN). # THEY should NOT BE the 'pacing item' for determining the window width! Dbg " Assigning labels to headers" label $w(LeftLabel) -bd 1 -relief flat -textvariable finfo(lbl,Left) label $w(RightLabel) -bd 1 -relief flat -textvariable finfo(lbl,Right) # These hold the following text widgets and the scrollbars. The reason # for the frame is purely for aesthetics. It just looks nicer, IMHO, # to "embed" the scrollbars within the text widget # (these won't need to be global) set leftFrame [frame $w(client).left -bd 1 -relief sunken] set rightFrame [frame $w(client).right -bd 1 -relief sunken] scrollbar $w(LeftHSB) -borderwidth 1 -orient horizontal -command \ [list $w(LeftText) xview] scrollbar $w(RightHSB) -borderwidth 1 -orient horizontal -command \ [list $w(RightText) xview] # By default, CREATE these at the USERS requested size... # However, will likely be shrunk to keep the INITIAL display onScreen if {2 > [scan $opts(geometry) "%dx%d" width height]} { popmsg "Invalid geometry setting:\n$opts(geometry)\n \ Reverting to 80x30" "Improper syntax..." lassign {80 30} width height } text $w(LeftText) -padx 0 -wrap none -width $width -height $height \ -bd 0 -yscrollcommand [list vscroll-sync 1] \ -xscrollcommand [list hscroll-sync 1] text $w(RightText) -padx 0 -wrap none -width $width -height $height \ -bd 0 -yscrollcommand [list vscroll-sync 2] \ -xscrollcommand [list hscroll-sync 2] # Technically, we lack the data to configure this properly until both # primary files have been loaded into the above text widgets. But we # need them right NOW for constructing the overall window layout. # Remaining options happen later via "prefapply" and "cfg-line-info" canvas $w(LeftInfo) -highlightthickness 0 canvas $w(RightInfo) -highlightthickness 0 # this widget is the two line display showing the current line, so # one can compare character by character if necessary. # N.B> Best when font used is Constant-Width! text $w(BottomText) -wrap none -borderwidth 1 -height 2 -width 0 # this is BASICALLY how we highlight those bytes that are different... # the bottom window (lineview) uses a tag to highlight mismatches, # so we need to configure that tag as requested $w(BottomText) tag configure diff {*}$opts(bytetag) # Set up text tags for the 'current diff' (the one chosen by the 'next' # and 'prev' buttons) .vs. any ol' diff region. All diff regions are # given the 'diff' tag initially... # As 'next' and 'prev' are pressed, to scroll through the differences, # one particular diff region is always chosen as the 'current diff', and # is set off from the others via the 'curr' tag -- in particular, so its # obvious which diff regions in the left and right-hand text widgets align. # N.B> THIS DEFINES THE TAG PRECEDENCE ORDER # Any further downstream code should only ever RE-cfg IN THIS ORDER! # Introspecting to obtain this (ordered) list is the PREFERRED method foreach widget [list $w(LeftText) $w(RightText)] { $widget configure {*}$opts(textopt) foreach t {diff curr del ins chg overlap inline} { $widget tag configure ${t}tag {*}$opts(${t}tag) } $widget tag raise sel ;# Keep this on top } # build the map... # we want the map to basically resemble a scrollbar, so we'll # steal some information from one of the scrollbars we just created... set color [$w(LeftHSB) cget -troughcolor] set ht [$w(LeftHSB) cget -highlightthickness] set cwidth [expr {[winfo reqheight $w(LeftHSB)] - ($ht * 2)}] # At the widget level, its just a frame holding a canvas... frame $w(map) -bd 1 -relief sunken -takefocus 0 -highlightthickness 0 canvas $w(mapCanvas) -width [expr {$cwidth + 1}] \ -yscrollcommand map-resize -background $color -borderwidth 0 \ -relief sunken -highlightthickness 0 # ... but for the REAL map, we want an IMAGE we can draw into INSERTED # in that canvas, along with (dummy) linework for a 'scrollbar thumb' # N.B> coords (number of, nor values) dont matter, as 'map-move-thumb' # REWRITES them as a properly positioned, hollow, 3D rectangle (later on) set w(mapImg) [image create photo] $w(mapCanvas) create image 1 1 -image $w(mapImg) -anchor nw $w(mapCanvas) create line 0 0 0 0 -width 1 -tags thumbUL -fill white $w(mapCanvas) create line 1 1 1 1 -width 1 -tags thumbLR -fill black pack $w(mapCanvas) -side top -fill both -expand y # Complete the scrollbar simulation with bindings for interaction bind $w(mapCanvas) {handleMapEvent B1-Press %y} bind $w(mapCanvas) {handleMapEvent B1-Motion %y} bind $w(mapCanvas) {handleMapEvent B1-Release %y} bind $w(mapCanvas) {handleMapEvent B2-Press %y} bind $w(mapCanvas) {handleMapEvent B2-Release %y} # Again, wheel scrolling over the MAP window SHOULD also work # - but can only target the THEN g(activeWindow) text widget foreach evt {Button-4 Button-5 Shift-Button-4 Shift-Button-5} { eval bind $w(mapCanvas) <$evt> \ "{event generate \$g(activeWindow) <$evt> -when head}" } foreach evt {MouseWheel Shift-MouseWheel} { eval bind $w(mapCanvas) <$evt> \ "{event generate \$g(activeWindow) <$evt> -delta %D -when head}" } # this is a grip for resizing the sides relative to each other. button $w(client).grip -borderwidth 3 -relief raised \ -cursor sb_h_double_arrow -image resize -takefocus 0 bind $w(client).grip {pane-drag $w(client) %X} # use grid to manage the widgets in the left side frame grid $w(LeftInfo) -row 0 -column 1 -sticky nsew grid $w(LeftText) -row 0 -column 2 -sticky nsew grid $w(LeftHSB) -row 1 -column 1 -sticky ew -columnspan 2 grid rowconfigure $leftFrame 0 -weight 1 grid rowconfigure $leftFrame 1 -weight 0 grid columnconfigure $leftFrame 0 -weight 0 grid columnconfigure $leftFrame 1 -weight 0 grid columnconfigure $leftFrame 2 -weight 1 # likewise for the right... grid $w(RightInfo) -row 0 -column 0 -sticky nsew grid $w(RightText) -row 0 -column 1 -sticky nsew grid $w(RightHSB) -row 1 -column 0 -sticky ew -columnspan 2 grid rowconfigure $rightFrame 0 -weight 1 grid rowconfigure $rightFrame 1 -weight 0 grid columnconfigure $rightFrame 0 -weight 0 grid columnconfigure $rightFrame 1 -weight 1 # use grid to manage the labels, frames and map. We're going to # toss in an extra row just for the benefit of our dummy frame. # the intent is that the dummy frame will match the height of # the horizontal scrollbars so the map stops at the right place... grid $w(LeftLabel) -row 0 -column 0 -sticky ew grid $w(RightLabel) -row 0 -column 2 -sticky ew grid $leftFrame -row 1 -column 0 -sticky nsew -rowspan 2 grid $w(map) -row 1 -column 1 -sticky ns grid $w(client).grip -row 2 -column 1 grid $rightFrame -row 1 -column 2 -sticky nsew -rowspan 2 grid $w(BottomText) -row 3 -column 0 -sticky ew -columnspan 4 grid rowconfigure $w(client) 0 -weight 0 grid rowconfigure $w(client) 1 -weight 1 grid rowconfigure $w(client) 2 -weight 0 grid rowconfigure $w(client) 3 -weight 0 grid columnconfigure $w(client) {0 2} -weight 100 -uniform a grid columnconfigure $w(client) 1 -weight 0 # this adjusts the variable g(activeWindow) to be whatever text # widget receives the focus via a mouseclick... bind $w(LeftText) <1> {set g(activeWindow) $w(LeftText)} bind $w(RightText) <1> {set g(activeWindow) $w(RightText)} set g(activeWindow) $w(LeftText) ;# establish a default # Finally, we need wrappers for all these main text procs: # 1. monitor L/R line selections (for loading the line comparison widget) # 2. produce ReadOnly semantics (from users standpoint only) rename $w(RightText) $w(RightText)_ proc $w(RightText) {cmd args} $::textROfcn rename $w(LeftText) $w(LeftText)_ proc $w(LeftText) {cmd args} $::textROfcn rename $w(BottomText) $w(BottomText)_ proc $w(BottomText) {cmd args} $::textROfcn } ############################################################################### # Use this code as the replacement body for Text Widgets needing to be READONLY # There are multiple reasons: # 1. To watch insert-cursor repositions and update the line comparison window # - but ONLY when occuring in the ".client.*.text" windows (main L/R) # 2. To implement a READONLY text widget (WITHOUT using "-state disabled"): # - BLOCKS all attempts to modify content (via CONVENTIONAL subcmds) # + BUT implements ALTERNATIVE subcmds for use by OUR OWN code ############################################################################### set textROfcn { global g w opts set real "[lindex [info level 0] 0]_" ;# N.B> Note trailing underscore!! lassign $args a1 a2 set result {} # Content modifications are DISALLOWED unless done with OUR "synonyms"... # (nothing more than simple capitalizations of the 'proper' subcmd) # Intent is to prevent modifications from unsanctioned sources (eg. User) # In simpler terms: your basic Read Only Text Widget # ('see' is included because it can cause UNCOMMANDED scrolling) set synonyms {INSERT insert DELETE delete REPLACE replace SEE see} switch -- $cmd { allow { if {$a1 == "see" && $a2 in {1 0}} { # Fictitious command "allows" widget to permit 1 'see' to WORK set g(see$real) $a2} { set g(see$real) 0} } see { if {[info exists g(see$real)] && $g(see$real)} { # CONDITIONALLY allowed to operate (for certain Class Bindings) set result [eval $real $cmd $args] set g(see$real) 0 # else see IS being BLOCKED (NO scrolling w/o our cooperation) } { Dbg "$real: ${cmd}(?): DENIED: ReadOnly" } # (sniff... what a perfect place for a C-language fall-thru case!) } insert - delete - replace { Dbg "$real: $cmd: DENIED: ReadOnly" # BLOCKs actions (NOTHING changes w/o our cooperation) } SEE - INSERT - DELETE - REPLACE - default { set cmd [string map $synonyms $cmd] # But allow OUR transliterated synonyms (whenever present) set result [eval $real $cmd $args] } } # But if the Line comparison window is visible AND a L/R window insertion # cursor was MOVED to a NEW line, then update the comparison display if {$opts(showlineview) && [string match {.client.*.text_} $real] && $cmd == "mark" && $a1 == "set" && $a2 == "insert" && [set i [file rootname [$real index insert]]] && $g(bLnum) != $i} { # Remember screenline number for next time, then update set g(bLnum) $i set left [$w(LeftText)_ get $i.0 $i.0lineend] set rght [$w(RightText)_ get $i.0 $i.0lineend] $w(BottomText) REPLACE 1.0 end "< $left\n> $rght" # find characters that are different, and hilite/tag them if {$left != $rght} { # N.B> c "offset" compensates for OUR "< " or "> " prefix markings set c 2 foreach l [split $left {}] r [split $rght {}] { if {[string compare $l $r] != 0} { $w(BottomText) tag add diff 1.$c "1.$c+1c" $w(BottomText) tag add diff 2.$c "2.$c+1c" } incr c } # do not draw attention to either of the 'NL' chars $w(BottomText) tag remove diff "1.0 lineend" $w(BottomText) tag remove diff "2.0 lineend" } } return $result } ############################################################################### # Perform inline data re-computation and/or re-tagging across ALL hunks ############################################################################### proc compute-inlines {optNam {retag 0}} { global g w # Translate from TkDiff optionName to algorithm style name set style(showinline1) "byte" set style(showinline2) "ratcliff" # Optionally remove ALL inline tags/data (so new ones MAY be added) # N.B. If neither arg is TRUE, then CALLER must do "array unset ..." if {$retag || $optNam == {}} { $w(LeftText) tag remove inlinetag 1.0 end $w(RightText) tag remove inlinetag 1.0 end array unset g "inline,*" set retag true ;# ensure UNtagged are RE-evaluated by "de-skew-hunk" } # Compute inline data per requested algorithm style # PRIOR data (inline,*) is expected to be deleted BEFORE invocation foreach hID $g(diff) { # Remember: only chg-type hunks can EVER have inline diffs if {[string match "*c*" "$hID"]} { if {$optNam != {}} { lassign $g(scrInf,$hID) Ls Le P(1) na na P(2) # Determine last UN-padded Lnum, then process L/R line pairs set first $Ls set last [expr {$P(1) ? $Le-$P(1) : $Le-$P(2)}] while {$Ls <= $last} { set s1 "[$w(LeftText) get $Ls.0 $Ls.end]" set s2 "[$w(RightText) get $Ls.0 $Ls.end]" find-inline-diff-$style($optNam) $hID \ [expr {$Ls - $first}] "$s1" "$s2" incr Ls ;# increment line number and iterate } # Put these tags back in place if {$retag} {remark-inline $hID} } elseif {$retag} {de-skew-hunk $hID} } } } ############################################################################### # Functionality: Inline diffs # Athr: Michael D. Beynon : mdb - beynon@yahoo.com # Date: 04/08/2003 : mdb - Added inline character diffs. # 04/16/2003 : mdb - Rewrote longest-common-substring to be faster. # - Added byte-by-byte algorithm. # 08Oct2017 : mpm - Simplified byte-by-byte alg. # - Revised generated output data format (both alg.) # 12Jun2018 : mpm - Rewrote lcs-string (again) to be even faster. # # The recursive version is derived from the Ratcliff/Obershelp pattern # recognition algorithm (Dr Dobbs July 1988), where we search for a longest # common substring between two strings. This match is used as an anchor, # around which we recursively do the same for the two left and two right # remaining pieces (omitting the anchor). # This precisely determines the location of the intraline tags. ############################################################################### proc lcs-string {s1 off1 len1 s2 off2 len2 lcsoff1_ref lcsoff2_ref} { upvar $lcsoff1_ref lcsoff1 upvar $lcsoff2_ref lcsoff2 set snippet "" set snippetlen 0 set longestlen 0 # extract just the search regions for efficiency in string searching set s1 [string range $s1 $off1 [expr $off1+$len1-1]] set s2 [string range $s2 $off2 [expr $off2+$len2-1]] set snpBgn 0 for {set tmpoff -1} {$snippetlen < $len2-$snpBgn} {incr snpBgn} { # increase size of matching snippet while {$snippetlen < $len2-$snpBgn} { set tmp "$snippet[string index $s2 [expr $snpBgn+$snippetlen]]" if {[set i [string first $tmp $s1]] == -1} { break } set tmpoff $i set snippet $tmp incr snippetlen } if {$snippetlen > 0} { # new longest? if {$tmpoff != -1 && $snippetlen > $longestlen} { set longestlen $snippetlen set lcsoff1 [expr $off1+$tmpoff] set lcsoff2 [expr $off2+$snpBgn] } # drop 1st char of prefix, but keep size the same as longest if {$snippetlen < $len2-$snpBgn} { set snippet "[string range $snippet 1 end][string index $s2 \ [expr $snpBgn+$snippetlen]]" } } } return $longestlen } proc fid-ratcliff-aux {hID pairID s1 off1 len1 s2 off2 len2} { global g if {$len1 <= 0 || $len2 <= 0} { if {$len1 == 0} { lappend g(inline,$hID) r $pairID $off2 [expr $off2+$len2] } elseif {$len2 == 0} { lappend g(inline,$hID) l $pairID $off1 [expr $off1+$len1] } return 0 } set cnt 0 set lcsoff1 -1 set lcsoff2 -1 # Non-obvious speedup: Best if argsets passed in (longer, shorter) order # (operation is commutative and performs fewer internal iterations) if {$len2 < $len1} { set ret [lcs-string $s1 $off1 $len1 $s2 $off2 $len2 lcsoff1 lcsoff2] } else { set ret [lcs-string $s2 $off2 $len2 $s1 $off1 $len1 lcsoff2 lcsoff1] } if {$ret > 0} { set rightoff1 [expr $lcsoff1+$ret] set rightoff2 [expr $lcsoff2+$ret] incr cnt [expr 2*$ret] if {$lcsoff1 > $off1 || $lcsoff2 > $off2} { # left incr cnt [fid-ratcliff-aux $hID $pairID \ $s1 $off1 [expr $lcsoff1-$off1] \ $s2 $off2 [expr $lcsoff2-$off2]] } if {$rightoff1<$off1+$len1 || $rightoff2<$off2+$len2} { # right incr cnt [fid-ratcliff-aux $hID $pairID \ $s1 $rightoff1 [expr $off1+$len1-$rightoff1] \ $s2 $rightoff2 [expr $off2+$len2-$rightoff2]] } } else { lappend g(inline,$hID) r $pairID $off2 [expr $off2+$len2] lappend g(inline,$hID) l $pairID $off1 [expr $off1+$len1] incr cnt } return $cnt } proc find-inline-diff-ratcliff {hID pairID s1 s2} { global g if {![set len1 [string length $s1]] || ![set len2 [string length $s2]] } { return 0 } return [fid-ratcliff-aux $hID $pairID $s1 0 $len1 $s2 0 $len2] } proc find-inline-diff-byte {hID pairID s1 s2} { global g if {![set len1 [string length $s1]] || ![set len2 [string length $s2]] } { return 0 } set lenmin [min $len1 $len2] set cnt 0 set size 0 for {set i 0} {$i <= $lenmin} {incr i} { if {[string index $s1 $i] == [string index $s2 $i]} { # start/continue a NON-diff region if {$size} { # which ENDS a diff region lappend g(inline,$hID) r $pairID [expr $i-$size] $i lappend g(inline,$hID) l $pairID [expr $i-$size] $i set size 0 incr cnt } } else { incr size } } if {$size} { # ended in a diff region lappend g(inline,$hID) r $pairID [expr $i-$size] $len2 lappend g(inline,$hID) l $pairID [expr $i-$size] $len1 incr cnt } return $cnt } ############################################################################### # create (if necessary) and show the find dialog ############################################################################### proc srch-text {} { global g w if {![Dialog NONMODAL $w(srch)]} { wm title $w(srch) "$g(name) Find" wm transient $w(srch) . wm group $w(srch) . # we don't want the window to be deleted, just hidden from view wm protocol $w(srch) WM_DELETE_WINDOW {Dialog dismiss $w(srch)} frame $w(srch).content -bd 2 -relief groove pack $w(srch).content -side top -fill both -expand y -padx 0 -pady 5 frame $w(srch).buttons pack $w(srch).buttons -side bottom -fill x -expand n button $w(srch).buttons.doit -text "Find Next" -command srchit button $w(srch).buttons.dismiss -text "Dismiss" \ -command "Dialog dismiss $w(srch)" pack $w(srch).buttons.dismiss -side right -pady 5 -padx 0 pack $w(srch).buttons.doit -side right -pady 5 -padx 1 set ff $w(srch).content.findFrame frame $ff -height 100 -bd 2 -relief flat pack $ff -side top -fill x -expand n -padx 0 -pady 5 label $ff.label -text "Find what:" -underline 2 entry $ff.entry -textvariable g(findString) checkbutton $ff.searchCase -text "Ignore Case" -indicatoron true \ -variable g(findIgnoreCase) -offvalue 0 -onvalue 1 grid $ff.label -row 0 -column 0 -sticky e grid $ff.entry -row 0 -column 1 -sticky ew grid $ff.searchCase -row 0 -column 2 -sticky w grid columnconfigure $ff 0 -weight 0 grid columnconfigure $ff 1 -weight 1 grid columnconfigure $ff 2 -weight 0 # we need this in other places... set w(findEntry) $ff.entry bind $ff.entry srchit set of $w(srch).content.optionsFrame frame $of -bd 2 -relief flat pack $of -side top -fill y -expand y -padx 10 -pady 10 label $of.directionLabel -text "Search Direction:" -anchor e radiobutton $of.directionForward -text "Down" -indicatoron true \ -variable g(findDirection) -value "-forward" radiobutton $of.directionBackward -text "Up" -indicatoron true \ -variable g(findDirection) -value "-backward" label $of.windowLabel -text "Window:" -anchor e radiobutton $of.windowLeft -text "Left" -indicatoron true \ -variable g(activeWindow) -value $w(LeftText) radiobutton $of.windowRight -text "Right" -indicatoron true \ -variable g(activeWindow) -value $w(RightText) label $of.searchLabel -text "Search Type:" -anchor e radiobutton $of.searchExact -text "Exact" -indicatoron true \ -variable g(findType) -value "-exact" radiobutton $of.searchRegexp -text "Regexp" -indicatoron true \ -variable g(findType) -value "-regexp" grid $of.directionLabel -row 1 -column 0 -sticky w grid $of.directionForward -row 1 -column 1 -sticky w grid $of.directionBackward -row 1 -column 2 -sticky w grid $of.windowLabel -row 0 -column 0 -sticky w grid $of.windowLeft -row 0 -column 1 -sticky w grid $of.windowRight -row 0 -column 2 -sticky w grid $of.searchLabel -row 2 -column 0 -sticky w grid $of.searchExact -row 2 -column 1 -sticky w grid $of.searchRegexp -row 2 -column 2 -sticky w grid columnconfigure $of {0 1} -weight 0 grid columnconfigure $of 2 -weight 1 set g(findType) "-exact" set g(findDirection) "-forward" set g(findIgnoreCase) 1 set g(lastSearch) "" if {$g(activeWindow) == ""} { set g(activeWindow) [focus] if {$g(activeWindow) != $w(LeftText) && $g(activeWindow) != $w(RightText)} { set g(activeWindow) $w(LeftText) } } # On creation, flop it centerred (then let user put it anywhere) centerWindow $w(srch) } # Put it onscreen (NON MODAL) Dialog show $w(srch) $w(findEntry) } ############################################################################### # do the "Edit->Copy" functionality, by copying the current selection # to the clipboard ############################################################################### proc do-copy {} { clipboard clear -displayof . # figure out which window has the selection... catch { clipboard append [selection get -displayof .] } } ############################################################################### # search for the text in the find dialog ############################################################################### proc srchit {} { global g w set win $g(activeWindow) if {$win == ""} { set win $w(LeftText) } if {$g(lastSearch) != ""} { if {$g(findDirection) == "-forward"} { set start [$win index "insert +1c"] } else { set start insert } } else { set start 1.0 } if {$g(findIgnoreCase)} { set result [$win search $g(findDirection) $g(findType) -nocase \ -- $g(findString) $start] } else { set result [$win search $g(findDirection) $g(findType) \ -- $g(findString) $start] } if {[string length $result] > 0} { # if this is a regular expression search, get the whole line and try # to figure out exactly what matched; otherwise we know we must # have matched the whole string... if {$g(findType) == "-regexp"} { set line [$win get $result "$result lineend"] regexp $g(findString) $line matchVar set length [string length $matchVar] } { set length [string length $g(findString)] } set g(lastSearch) $result $win mark set insert $result $win tag remove sel 1.0 end $win tag add sel $result "$result + ${length}c" $win SEE $result focus $win } else { bell } } ############################################################################### # Build the menu bar AND the popup menu (Do AFTER client has been built) ############################################################################### proc build-menus {} { global g w opts finfo # We are building TWO distinct menu trees here: menuBar and popUp # Generate THEM and then we can let the factory build them all out set mB [menu $w(menubar)] set pM [menu $w(popupMenu)] # Export NAMING of cascaded nodes (factory uses the short local synonyms) # N.B> do NOT pre-CREATE such menus - Factory will do that set w(fileMenu) [set fM $w(menubar).file] set w(multiFileMenu) [set mFM $fM.multi] set w(viewMenu) [set vM $w(menubar).view] set w(helpMenu) [set hM $w(menubar).help] set w(editMenu) [set eM $w(menubar).edit] set w(mergeMenu) [set gM $w(menubar).merge] set w(markMenu) [set mM $w(menubar).marks] # Data specification for driving the MENU building Factory ############################################################# # Menu Type Label { positional type-specific args } # Ul: underline # Mu: menu # Items enclosed in [ ] Cm: command # are optional as Ac: accelerator-link # depicted Vr: state-variable # Tp: Tooltip text # # # # # # # # # # # # # # # # # .abc separator {} { } # .def cascade Lb { Ul Mu [Tp] } # .mno command Lb { Ul Cm [Ac] [Tp] } # .xyz checkbutton Lb { Ul [Cm] [Ac] Vr Tp } foreach {Mu Ty Lb Ul} [subst -nocommands { $pM comm "First Diff" {0 {move first} navFrst} $pM comm "Previous Diff" {0 {move -1} navPrev} $pM comm "Center Current Diff" {0 {center} navCntr} $pM comm "Next Diff" {0 {move 1} navNext} $pM comm "Last Diff" {0 {move last} navLast} $pM separator {} {} $pM comm "Find Nearest Diff" {13 {moveNearest \$g(activeWindow) xy [winfo pointerx \$g(activeWindow)] [winfo pointery \$g(activeWindow)]} } $pM separator {} {} $pM comm "Find..." {1 {srch-text} genFind} $pM comm "Edit" {0 {do-edit} genEdit} $pM separator {} {} $pM comm "Copy Selection" {5 {do-copy} } $mB casc "File" {0 $fM} $fM comm "New..." {0 "do-new-diff" {} "Select new input parameters and compute a new Diff"} $fM casc "File List" {5 $mFM "Choose a different file pair from those derived from the present input"} $mFM comm "Previous File" {0 {multiFileMenu prev 0} genPvfile "Choose the previous file pair"} $mFM comm "Next File" {1 {multiFileMenu next 0} genNxfile "Choose the next file pair"} $mFM separator {} {} $fM comm "Recompute Diffs" {0 {reCalcD user} {} genRecalc "Recompute all difference regions for the current file"} $fM separator {} {} $fM comm "Write Report..." {0 {rpt-gen popup} {} "Configure and produce Diff textual content and statistical output"} $fM separator {} {} $fM comm "Exit" {1 {do-exit} genXit "Immediately terminate $g(name)"} $mB casc "Edit" {0 $eM} $eM comm "Copy" {0 {do-copy} {} "Copy the currently selected text to the clipboard"} $eM separator {} {} $eM comm "Find..." {0 {srch-text} genFind "Pop up a dialog to search for a string within either file"} $eM separator {} {} $eM comm "Ignore CDR" {0 {ignore-hunk} {} "Suppress the CDR to no longer be seen as a Difference region"} $eM comm "Split..." {0 {splcmbDlg 0} {} "Split the current diff at specified bounds"} $eM comm "Combine..." {2 {splcmbDlg 1} {} "Combine the current diff region with ADJACENT neighbor(s)"} $eM separator {} {} $eM comm "Edit File 1" {10 {set g(activeWindow) $w(LeftText);do-edit} {} "Launch an editor for the left side File"} $eM comm "Edit File 2" {10 {set g(activeWindow) $w(RightText);do-edit} {} "Launch an editor for the right side File"} $eM separator {} {} $eM comm "Preferences..." {0 {customize} {} "Pop up a window to customize $g(name)"} $mB casc "View" {0 $vM} $vM checkb "Ignore White Spaces" {7 {reCalcD ignblanks} {} opts(ignoreblanks) "If set, applys whitespace options during the Diff"} $vM checkb "Ignore Blank Lines" {7 {reCalcD ignEmptyLn} {} opts(ignoreEmptyLn) "If set, suppress empty lines from causing a Diff"} $vM checkb "Ignore RE-matched Lines" {7 {reCalcD ignoreRegexLn} {} opts(ignoreRegexLn) "If set, suppress Diffs from lines matching Regular Expression(s)"} $vM separator {} {} $vM checkb "Show Line Numbers" {12 {do-show-Info showln} {} opts(showln) "If set, show line numbers beside each line of each file"} $vM checkb "Show Change Bars" {12 {do-show-Info showcbs} {} opts(showcbs) "If set, show the changebar column for each line of each file"} $vM checkb "Show Diff Map" {5 {do-show-map} {} opts(showmap) "If set, display the graphical 'Diff Map' in the center of the display"} $vM checkb "Auto Center" {0 {if {\$opts(autocenter)} {center}} {} opts(autocenter) "If set, moving to another diff region centers the diff on the screen"} $vM checkb "Auto Select" {1 {} {} opts(autoselect) "If set, automatically selects the nearest diff region while scrolling"} $vM checkb "Show Line Comparison Window" {11 {do-show-lineview} {} opts(showlineview) "If set, display the window with byte-by-byte differences"} $vM checkb "Show Inline Comparison (byte)" {24 {do-show-inline showinline1} {} opts(showinline1) "If set, display inline byte-by-byte differences"} $vM checkb "Show Inline Comparison (recursive)" {24 {do-show-inline showinline2} {} opts(showinline2) "If set, display inline recursive based differences"} $vM separator {} {} $vM checkb "Synchronize Scrollbars" {0 {} {} opts(syncscroll) "If set, scrolling either window will scroll both windows"} $vM separator {} {} $vM comm "First Diff" {0 {move first} navFrst "Go to the first difference"} $vM comm "Previous Diff" {0 {move -1} navPrev "Go to the diff region just prior to the current diff region"} $vM comm "Center Current Diff" {0 {center} navCntr "Center the display around the current diff region"} $vM comm "Next Diff" {0 {move 1} navNext "Go to the diff region just after the current diff region"} $vM comm "Last Diff" {0 {move last} navLast "Go to the last difference"} $mB casc "Mark" {3 $mM} $mM comm "Bookmark Current Diff" {0 {bkmark creat} {} "Create a Bookmark for the current difference region"} $mM comm "Clear Current Bookmark" {0 {bkmark erase} {} "Clear the Bookmark for the current difference region"} $mB cascade "Merge" {0 $gM} $gM checkb "Show Merge Window" {9 {do-show-merge 1} {} g(showmerge) "Pops up a window showing the current merge results"} $gM comm "Write Merge File..." {6 {merge-write-file} {} "Write the merge file to disk AFTER confirming the filename first"} $mB cascade "Help" {0 $hM} $hM comm "On Command Line" {3 {do-usage gui} {} "Show help on the command line arguments"} $hM comm "On GUI" {3 {do-help} {} "Show help on how to use the Graphical User Interface"} $hM comm "On Preferences" {3 {do-help-prefs} {} "Show help on the user-settable preferences"} $hM separator {} {} $hM comm "About $g(name)" {0 {do-about} {} "Show information about this application"} $hM comm "About Wish" {6 {about_wish} {} "Show information about the TK Windowing-Shell (Wish)"} $hM comm "About Diff" {6 {about_diff} {} "Show information about the diff-engine"} }] { # THIS is the MENU factory (which processes the above list) # N.B> for those items HAVING accelerators, THEY will be attached # LATER - all we do NOW is DEFINE to which menuItems they should GO switch -glob $Ty { ca* { lassign $Ul Ul mU Tp $Mu add cascade -label $Lb -underline $Ul -menu [menu $mU] if {$Tp!={}} { set g(tooltip,$Lb) "$Tp" } } co* { lassign $Ul Ul Cm Ac Tp $Mu add command -label $Lb -underline $Ul -command $Cm if {$Ac!={}} { lappend w(Accel,$Ac) $Mu [$Mu index end] } if {$Tp!={}} { set g(tooltip,$Lb) "$Tp" } } ch* { lassign $Ul Ul Cm Ac Vr Tp $Mu add checkbutton -label $Lb -underline $Ul -variable $Vr if {$Ac!={}} { lappend w(Accel,$Ac) $Mu [$Mu index end] } if {$Cm!={}} { $Mu entryconfig [$Mu index end] -command $Cm } set g(tooltip,$Lb) "$Tp" } s* { $Mu add separator } } } ### Silly extra things easier to do from OUTSIDE the factory... # # Alternate tooltip (for when TkDiff REMOVES the "..." from the label) set "g(tooltip,Write Merge File)" \ "Write the merge file to disk USING the command line specified name" # And this just simply ISN'T a user-modifiable binding (perhaps should be?) $pM entryconfigure "Find Near*" -accelerator "Dbl-Click" # Populate the multiFileMenu with the OTHER file pairs-in-waiting reload-multifile $finfo(fPairs) # Establish the binding to provide menuItem Tooltips foreach m "$fM $eM $vM $mM $gM $hM" { bind $m <> {showTooltip menu %W} } # We also need the bindings to provide the Popup menu as well # N.B> probably best if these windows ALREADY exist foreach win "LeftText RightText RightInfo LeftInfo mapCanvas" { bind $w($win) <3> {show-popupMenu %X %Y} } # Is our binding debugger present (sourceable via the prefs file) ? if {[info procs Dbg-UI] != {}} { $w(menubar) add command -label "Dbg-UI" -underline 0 \ -command {if {[winfo exists .dbgUI]} {destroy .dbgUI} {Dbg-UI}} } } ############################################################################### # Enter names of file pairs accessible for diffing into the menu ############################################################################### proc reload-multifile {pairs} { global w finfo # Empty old entries out first (if any) ... # (presupposes it ALWAYS has 'prev, next, separator' as first 3 entries) if {[$w(multiFileMenu) index end] > 2} { $w(multiFileMenu) delete 3 end } # then append entries that exist NOW (caller tells us how many that is) set i 0 while {[incr i] <= $pairs} { $w(multiFileMenu) add radiobutton -value $i -variable finfo(fCurpair) \ -label $finfo(lbl,[expr {$i * 2 - 1}]) \ -command [list multiFileMenu jump $i] } } ############################################################################### # Show explanation of an item (menu/toolbutton) in the status bar at the bottom # PRIMARILY used only for menu items: # Still works for buttons PROVIDED 'set_tooltips' was NOT CALLED for a popup # (for us, thats the Bookmark toolbuttons) ############################################################################### proc showTooltip {type wdg} { global g switch -- $type { menu { if {[catch {$wdg entrycget active -label} label]} { set label "" } if {[info exists g(tooltip,$label)]} { set g(statusInfo) $g(tooltip,$label) } else { set g(statusInfo) $label } } button { if {[info exists g(tooltip,$wdg)]} { set g(statusInfo) $g(tooltip,$wdg) } else { set g(statusInfo) "" } } } update idletasks } ############################################################################### # Build the toolbar, in text and/or image mode ############################################################################### proc build-toolbar {} { global w g opts # Create the toolbar AND the dynamic (reusable) Bookmark popup menu set w(bkmenu) [menu [set tb [frame $w(toolbar) -bd 0]].bkmenu] # Remember: ORDER OF CONSTRUCTION prescribes focus-Tabbing sequence ... # (so, get any non-focusable yet needed separators/labels out of the way) foreach nam { 1 2 3 4 5 6 } { toolsep $tb.sep$nam } set w(navLbl) [label $tb.navLbl -pady 0 -bd 2 -relief groove -text "Diff:"] set w(mrgLbl) [label $tb.mrgLbl -pady 0 -bd 2 -relief groove -text "Merge:"] set w(bkmLbl) [label $tb.bkmLbl -pady 0 -bd 2 -relief groove -text "BkMark:"] # The combo box set w(combo) $tb.combo ::combobox::combobox $w(combo) -bd 1 -editable 0 -width 20 -command moveTo # (do these NOW (no point in kludging up 'setBind'); FIXES focus-Tabbing) bind $w(combo) <> "[bind all <>] ; break" bind $w(combo) <> "[bind all <>] ; break" # Next, the simple BUTTONS (table driven enforces visual/naming uniformity) # Using a "factory" approach cuts down on the code verbosity somewhat. # (N.B> See "ANNOYANCE" below for details on 'TW' field) foreach {nam txt TW cmd tip} { rediff "Rediff" 40 {reCalcD user} {"Recompute and redisplay ALL difference regions"} ignCDR "Ignore CDR" 76 {ignore-hunk} {"Ignore Current diff region"} splitCDR "Split..." 44 {splcmbDlg 0} {"Split Diff region at specified bounds"} cmbinCDR "Combine..." 76 {splcmbDlg 1} {"Combine Diff region with ADJACENT neighbor(s)"} find "Find..." 44 {srch-text} {"Search for a string within either file"} firstCDR "First" 34 {move first} {"Move to First Diff region"} lastCDR "Last" 34 {move last} {"Move to Last Diff region"} prevCDR "Prev" 34 {move -1} {"Move to Preceeding Diff region"} nextCDR "Next" 34 {move 1} {"Move to Following Diff region"} ctrCDR "Center" 46 {center} {"Center Current Diff region"} bkmSet "Set" 26 {bkmark creat} {"Bookmark this CDR"} bkmRls "Clear" 34 {bkmark erase} {"Clear this CDR bookmark"} } { set_tooltips [set w(${nam}_im) \ [toolbutton $tb.${nam}_im -image ${nam}Img -command $cmd]] $tip # TK ANNOYANCE: '-width -1' CLAIMS to produce a minimal btn WIDTH ... # # Instead it does EXACTLY the same as not specifying ANY at all: just # USES an 'average width' TIMES the #-of-Lbl-chars which wastes TONS # of space - Even MORE SO w/proportional fonts! # # We will CONSTRAIN it OURSELF by injecting an extra frame WE control # (mildly ugly approach, but SHOULD work multi-platform: +/- ?fonts?) # (We DO the same for -height, but thats just a constant 22 pixels) set_tooltips [set w(${nam}_tx) \ [toolbutton [frame $tb.${nam}_tx -width $TW -height 22 -bd 0].btn \ -text $txt -command $cmd]] $tip } # The remaining items (managing of EXISTING bookmarks) dont need Tooltips # (next two lines forms a ?'mini-widget'?: a scrollable frame of widgets) # (with the FOLLOWING two being its 'scroller btns') set w(bkmCvs) [canvas $tb.bCvs -height 22 -xscrollcom {bkmark set} \ -bd 0 -highlightthick 0] set w(bkmSF) [frame $w(bkmCvs).f -bd 0] # N.B> NEVER supply any dimensions to w(bkmSF)!! (details in 'bkmark') set w(bkmSL) [button $tb.bSL -image arroWl -command {bkmark scroll -1}] set w(bkmSR) [button $tb.bSR -image arroWr -command {bkmark scroll 1}] # Finally - INSERT our widget-fillable frame INSIDE the scrollable canvas $w(bkmCvs) create window 0 0 -anchor nw -window $w(bkmSF) # Last, do the RADIO buttons (N.B> are NOT part of focus-Tabbing) # A 2nd Factory is easier as each requires a specific extra term ('val'). # Focus-Tabbing is DISALLOWED (too easy to accidently toggle them that # way and NOT notice it) so they have no effect on the focus sequence # Besides - hotkeys exist for them anyway - so keyboard remains viable # N.B> Somehow UNAFFECTED by text-style oversizing (???) Whatever.... foreach {nam val txt cmd tip} { mrgC1 1 "L" {do-merge-choice 1} {"select the diff on the left for merging"} mrgC2 2 "R" {do-merge-choice 2} {"select the diff on the right for merging"} mrgC12 12 "LR" {do-merge-choice 12} {"select the diff on the left then right for merging"} mrgC21 21 "RL" {do-merge-choice 21} {"select the diff on the right then left for merging"} } { set_tooltips [set w(${nam}_im) \ [radiobutton $tb.${nam}_im -variable g(toggle) -takefocus 0 \ -image ${nam}Img -indicatoron 0 -selectcolor $w(selcolor) \ -value $val -command $cmd]] $tip set_tooltips [set w(${nam}_tx) \ [radiobutton $tb.${nam}_tx -variable g(toggle) -takefocus 0 \ -text $txt -indicatoron 1 \ -value $val -command $cmd]] $tip } # Assemble each piece WHERE it belongs, # choosing the Txt/Img variations as needed, cfg-toolbar true } ############################################################################### # By default, (Re-)Populate Toolbar w/preferred button styling (IFF misaligned) # (BUT when init==1): COMPOSE & MAP the Toolbar widgets where they belong ############################################################################### proc cfg-toolbar {{init 0}} { global w opts # (shorten some NEEDED variables, and provide a meta-pgming translation) lassign "$w(toolbar) $opts(toolbarIcons) _tx _im" tb I btn(0) btn(1) # Generally, we only need to SWAP OUT certain toolbar items in response # to the user toggling a preference (txt .vs. iconic buttons) BECAUSE # the 'grid' by default REMEMBERS all the items we ever put into it ... if {$init} { # ...BUT - if this IS the VERY FIRST invocation we must 'grid' it ALL # (plus make any final 1-TIME adjustments to various specific items) # "grid" makes this marginally harder because its ugly to config items # one-by-one AND get everything in ONE row (unlike "pack"), but we NEED # "grid" because it "remembers" where an item WAS if we simply UNMAP it. # Worse is we need CERTAIN items (toolbuttons) to be "stacked" into the # SAME grid-CELL so we can TOGGLE which variant of each IS mapped. # # So this may look weird as code - but dont argue with success! # First, list it all out (in left-to-right order): the ENTIRE Toolbar ! # - BUT (for now) ONLY as their "image" identities... THEN "grid" it, # AND THEN "grid" it AGAIN (after switching to their "text" forms) # # This should result in 'grid' KNOWING all of them, AND stacking BOTH # versions (_tx & _im) of any such toolbuttons INTO the SAME grid-CELL. set theRow [list $tb.combo $tb.sep1 $tb.rediff_im $tb.ignCDR_im \ $tb.splitCDR_im $tb.cmbinCDR_im $tb.find_im $tb.sep2 \ $tb.mrgLbl $tb.mrgC12_im $tb.mrgC1_im $tb.mrgC2_im \ $tb.mrgC21_im $tb.sep3 $tb.navLbl $tb.firstCDR_im \ $tb.lastCDR_im $tb.prevCDR_im $tb.nextCDR_im $tb.sep4 \ $tb.ctrCDR_im $tb.sep5 $tb.bkmLbl $tb.bkmSet_im \ $tb.bkmRls_im $tb.sep6 $tb.bSL $tb.bCvs $tb.bSR] grid {*}$theRow -padx 0 -sticky w # N.B> Phooey! The SIMPLE DIRECT way out didn't (QUITE yet) work..... # (see last line of this code-block: was FORMERLY the NEXT line!) # # It's NOT that it won't DO the OVERLAY, its that when mentioning a # KNOWN slave, it fails to 'increment' the COL for it as we imagined... # *BUT* ... there's ANOTHER way (via a "set theory" operation): # 1st REMOVE all the common items, THEN let them be added a 2ND time # to ensure any new 'OTHER' items FALL into their CORRECT columns! grid forget {*}[regsub -all {[^ ]+_im} $theRow {}] # # NOW we can RE-add everything AGAIN with it ALL being managed properly grid {*}[string map {_im _tx} $theRow] -row 0 -padx 0 -sticky w # Certain items (walk ALL the slaves) need just a bit more configuring # (including some tiny bits of UN-configuring from just above) # N.B> '-sticky' (like others) REWRITES its value - NOT merges! foreach item [grid slaves $tb] { if {[string match {*_im} $item]} { grid $item -pady 2 } \ elseif {[string match {*_tx} $item]} { grid $item -pady 2 # Time to put the REAL textbtn inside its frame - if it IS one! # (just dont LET it GRAB more space than we've ALLOWED it) if {[winfo exists $item.btn]} { pack propagate $item false pack $item.btn -fill both -expand yes } } \ elseif {[string match {*.bCvs} $item]} { grid $item -sticky ew } \ elseif {[string match {*sep?} $item]} { grid $item -padx 2 -pady 2 -sticky nsw } \ elseif {[string match {*.bS?} $item]} { $item config -repeatdelay 200 -repeatinterval 300 if {[string match {*R} $item]} { grid $item -padx 0 -sticky e } \ else { grid $item -padx 0 } } } # Sadly, theres no "grid $slave -column" to ASK "What col is it IN?", # instead yank it from the WHOLE slave-attr LIST (& mark it 'Stretchy') grid columnconfig $tb [lindex [grid info $tb.bCvs] 3] -weight 1 # Initially, HIDE the Bkmark scroll-btns (they'll come/go dynamically) grid remove $tb.bSL $tb.bSR # N.B> 'falling-thru' to below WILL UNMAP the UNDESIRED button forms } # Verify we have the DESIRED toolbtn FORM (txt/img) set as visible/hidden # N.B> There MAY be nothing to DO (if the Icon toggle hasnt been CHANGED) # (spin over ALL items partly because 'winfo' doesnt offer glob-specs) foreach item [winfo children $tb] { if {[string match {*_[it][mx]} $item] && [winfo ismapped $item] && ![string match "*$btn($I)" $item] } { # out with the old, in with the new grid remove $item grid [string map {_tx {} _im {}} $item]$btn($I) } } # Pgmr: Useful in identifying toolbar spacing/occupancy/stacking issues!! # foreach item [grid slaves $tb] {Dbg "[grid info $item]\t<-- $item" true} # Ensure 'relief' on ALL toolbutton items AGREE with the CURRENT setting if {$opts(relief)=="flat" && $I} { set newB 0 } { set newB 1 } # BUT, Radiobuttons IGNORE relief settings if they have an image, so set # THEIR borderwidth = 0 if the CURRENT RELIEF is intended to be flat foreach wdg [concat [info comm $tb.*$btn($I)] [info comm $tb.cvs.f.*]] { if {[string match {*.mrgC[12]*_im} $wdg]} { $wdg configure -relief $opts(relief) -bd $newB -selectc $w(selcolor) } { $wdg configure -relief $opts(relief) } } # Changing Icon<->Txt buttons MAY affect size of the Bookmark Scroll region after idle bkmark adjSz -1 } ############################################################################### # Construct the status window (a place for hints and/or SHORT messaging) ############################################################################### proc build-status {} { global g w frame $w(status) -bd 0 set w(statusLabel) $w(status).label set w(statusCurrent) $w(status).current # MacOS has a resize handle in the bottom right which will sit on top of # whatever is placed there. So, we add a little bit of whitespace there. # It's harmless, so let's just do it on all of the platforms. label $w(status).blank -image nullImg -width 16 -bd 1 -relief sunken label $w(statusCurrent) -textvariable g(statusCurrent) -anchor e \ -width 14 -borderwidth 1 -relief sunken -padx 4 -pady 2 label $w(statusLabel) -textvariable g(statusInfo) -anchor w -width 1 \ -borderwidth 1 -relief sunken -pady 2 pack $w(status).blank -side right -fill y pack $w(statusCurrent) -side right -fill y -expand n pack $w(statusLabel) -side left -fill both -expand y } ############################################################################### # handles simulated-scroll events over the map # Provides 3 modes: # B1-click (over trough) pages, B1-motion (over thumb) drags, or B2-click jumps # Once a button is down, the mode locks and mouse X-location becomes irrelevant ############################################################################### proc handleMapEvent {event y} { global g w opts #Dbg "handleMapEvent $event $y" switch -- $event { B1-Press { if {! $g(mapScrolling)} { set ty1 [lindex $g(thumbBbox) 1] set ty2 [lindex $g(thumbBbox) 3] if {$y >= $ty1 && $y <= $ty2} { # this captures the negative delta between the mouse press # and the top of the thumbbox. It's used so when we scroll # by moving the mouse, we can keep this distance constant. # (this is how all scrollbars work, and what is expected) set g(thumbDeltaY) [expr -1 * ($y - $ty1 - 2)] set g(mapScrolling) 3 } else { set g(mapScrolling) 1 } # Either way, mode is set and other mouse events are locked out } } B2-Press { # Set mode and lock out other mouse events if {! $g(mapScrolling)} { set g(mapScrolling) 2 } } B2-Release - B1-Motion { if {$g(mapScrolling) & 2} { if {$g(mapScrolling) == 3} { incr y $g(thumbDeltaY) } map-seek $y # Release our mouse event lock (B2-click completed) if {$g(mapScrolling) == 2} { set g(mapScrolling) 0 } } } B1-Release { show-status "" if {$g(mapScrolling) & 1} { set ty1 [lindex $g(thumbBbox) 1] set ty2 [lindex $g(thumbBbox) 3] # if we release over the trough (*not* over the thumb) # just scroll by the size of the thumb; ... # otherwise we must have been dragging the thumb and we're done if {$y < $ty1 || $y > $ty2} { if {$y < $ty1} { # if vertical scrollbar syncing is turned on, # all the other windows should toe the line # appropriately... $g(activeWindow) yview scroll -1 pages } else { $g(activeWindow) yview scroll 1 pages } } # Release our mouse event lock (B1 click/drag completed) set g(mapScrolling) 0 } } } } # makes a toolbar "separator" proc toolsep {w} { label $w -image [image create photo] -highlightthickness 0 -bd 1 -width 0 \ -relief groove return $w } proc toolbutton {w args} { global opts # create the button # Dflts for '-bd' AND '-pady' =1 (generally whats wanted anyway; don't set) button $w {*}$args # add minimal tooltip-like support bind $w [list toolbtnEvent %W] bind $w [list toolbtnEvent %W] bind $w [list toolbtnEvent %W] bind $w [list toolbtnEvent %W] $w configure -relief $opts(relief) return $w } # handle events in our fancy toolbuttons... proc toolbtnEvent {event w {isToolbutton 1}} { global g opts switch -- $event { "" - "" { showTooltip button $w if {$opts(fancyButtons) && $isToolbutton && [$w cget -state] == \ "normal"} { $w configure -relief raised } } "" - "" { set g(statusInfo) "" if {$opts(fancyButtons) && $isToolbutton} { $w configure -relief flat } } } } ############################################################################### # move the map thumb to correspond w/current shown text (just like a scrollbar) ############################################################################### proc map-move-thumb {y1 y2} { global g w # Scale the thumb height (subject to a minumum size big enough to 'grab') set thumbheight [max [expr {($y2-$y1) * $g(mapheight)}] $g(thumbMinHeight)] # L/R edge positions (-3 so right edge remains INSIDE our border) set x1 1 if {[info exists g(mapwidth)]} { set x2 [expr {$g(mapwidth) - 3}] } {set x2 0} # B/T edge positions (-2 so bottom edge remains INSIDE our border) # but ensure top edge wont exceed the top of the map itself set y1 [max [expr {int(($y1 * $g(mapheight)) - 2)}] 0] set y2 [expr {$y1 + $thumbheight}] if {$y2 > $g(mapheight)} { set y2 $g(mapheight) set y1 [expr {$y2 - $thumbheight}] } # extra offset values for upcomming drawing trick set dx1 [expr {$x1 + 1}] set dx2 [expr {$x2 - 1}] set dy1 [expr {$y1 + 1}] set dy2 [expr {$y2 - 1}] # Draw two L-shapes (1 light, 1 dark) aligned for a 3d appearance $w(mapCanvas) coords thumbUL $x1 $y2 $x1 $y1 $x2 $y1 $dx2 $dy1 $dx1 $dy1 \ $dx1 $dy2 $w(mapCanvas) coords thumbLR $dx1 $y2 $x2 $y2 $x2 $dy1 $dx2 $dy1 $dx2 \ $dy2 $dx1 $dy2 # Record bounding box (for use in event handler, eg., dragging, etc) set g(thumbBbox) [list $x1 $y1 $x2 $y2] } ############################################################################### # Attach bindings needed by each provided widget (per naming conventions) ############################################################################### proc setBinds {args} { global opts # Assign bindings based primarily on the "role" each widget plays in the UI # Expected are: the major Text windows (already wrapped for ReadOnly use) # - their matching Info Canvas (mostly for linenumber display) # - toplevels that house the primary appl displays (no dialogs) # All of these are valid as a bindtag (btag) so do whichever was passed-in foreach btag $args { if {[string match {*.info} $btag]} { # An Info widget is actually a Canvas PAIRED with a Text widget # In our configuration, they share equivalent Y-coords (w/acceptable X) # and can thus OPERATE as-if the event happened OVER that Text widget # Info widgets must pretend their dblclick occurred within # the COMPANION "*.text" widget instead (because a canvas # doesn't HAVE any "line indices" to locate (but the widget # relative coords STILL work because of physical alignment) set companion [string replace $btag end-3 end "text"] bind $btag \ [subst {moveNearest $companion xy %x %y ; break ;}] } elseif {[string match {*text} $btag]} { # OUR Text wdgs are (intentionally) READONLY, yet DO receive keystrokes # First some 'built-in' specific "features" for the L/R Text windows if {[string match {.client.*.text} $btag]} { bind $btag {moveNearest %W xy %x %y ; break} bind $btag {moveNearest %W mark insert ; break} } # Next, we need 'focus-Tabbing' to work properly everywhere ... # But the default Text CLASS bindings would presume that # a typed or should be "insert"ed instead # # So we'll reach AROUND the Text Class to the "all" bindtag where # 'focus-Tabbing lives, install them here, AND "break" so the # class rules NEVER see it. This LEAVES the Text Class unmodified # and thus fully functional for uses OUTSIDE the ones setup here. bind $btag <> "[bind all <>] ; break" bind $btag <> "[bind all <>] ; break" # ALL ABOUT cursor-based SCROLLING: # These following (assidiously named) 20 bindings are all about POSITIONING # the insert cursor (and MAYBE forming a selection) via the keyboard. But # each EXPECTS to scroll the window AS NEEDED, for visual feedback (and # user confirmation) which is EXACTLY the same reason TYPING does (so the # users SEES what they are doing). Thus scrolling is tied up with TYPING # as well as OTHER uses. # Yet our R/O widget BLOCKs TYPING - thus ALSO needs to BLOCK the # visualization aid ($widget see insert) it issues, because one CANT # POSSIBLY 'see' what HASNT been ALLOWED to HAPPEN! # This becomes easier to understand when realizing that OTHER forms of # scrolling (scrollbar, mouse) DO NOT update the insert cursor! Thus were # cursor-based scrolling NOT blocked, a simple key touch would then cause a # RADICAL scrollBACK to wherever the cursor was last left, to ENTER a key # that WE, in turn, WONT LET OCCUR! And the user then asking # "what the .... just happened?" # Sadly, there are "precedence" issues around trying to OVERRIDE the # TYPING binding () WITHOUT just "removing" it, which we CANT do, # as we have OTHER widget instances that truely NEED it to exist. # ONE solution MIGHT be to CLONE the Class bindings, hack them up and use # the RESULT as the Class for the R/O widgets. That felt dangerous at best # (interactions are both subtle AND widespread). # OUR "solution" was to provide a ficticious widget cmd: 'allow' bound to # EXACTLY THE SAME BINDINGS as all the PERMITTED movements (general # positioning and selection creation) but NOT to typing; binding them ALL # to the widget tag (ie. just AHEAD of the Class invocations but WITHOUT a # 'break'). Each call *allow*s 'see' to NOT BE BLOCKED for 1 invocation # only. Thus as BOTH bindings WILL FIRE, we are SIMPLY PERMITTING the Class # actions to function, while BLOCKING others, ALL without making ANY # modification to the Class bindings! # The only thing we MIGHT get *wrong* is failing to "allow" yet one more # binding (or one too many); which is INFINITELY easier to fix than hacking # even FURTHER on a CLONED class (endlessly?). # These are ALL targetted on the Arrowkeys with Mods= S/C/SC # (should also note that literals always WIN against virtuals in event # precedence battles ... IE.: which are you choosing to 'Give up' ? # These TWENTY bindings RESTORES Key-based cursor movement (as # pertains to SCROLLING) in support of simple movement AND the # creation of "selections". Each works by issuing a FAKE widget # cmd to OUR 'ROfcn' PERMITTING the (implicitly following) Text # Class-binding 'see' request to operate normally. Think of it # as "arming" the Class binding to function as designed. # # Distinction is that Class rules that ATTEMPT Ins/Del/Repl OPS # must also NOT have THEIR requests to 'see' permitted, thereby # ENSURING a **COMPLETE BLOCKAGE** of any modification effects! foreach A {"" Select} { foreach B {Next Prev} { foreach C {Char Line Word Para} { bind $btag <<$A$B$C>> {%W allow see 1} } } set B "Line" foreach C {Start End} { bind $btag <<$A$B$C>> {%W allow see 1} } } } else { # Anything ELSE has to be one of the two 'toplevel' frames we use... # Each is assigned ALL of the GLOBALLY defined bindings (because they # should act REGARDLESS of which 'contained' widget holds the focus). # This works because EVERY widget includes ITS toplevel as a bindtag # **BUT** requires the CHOICE of the bound-keys to not BE subject # to exclusivity (ie. using a 'break') bind $btag $opts(navCntr) { center } bind $btag $opts(navNext) { move 1 } bind $btag $opts(navPrev) { move -1 } bind $btag $opts(navFrst) { move first } bind $btag $opts(navLast) { move last } bind $btag $opts(genEdit) { do-edit %X %Y} bind $btag $opts(genFind) { srch-text } bind $btag $opts(genNxfile) { multiFileMenu next 0 } bind $btag $opts(genPvfile) { multiFileMenu prev 0 } bind $btag $opts(genXit) { do-exit } bind $btag $opts(genRecalc) { reCalcD user } bind $btag $opts(mrgLeft) { do-merge-choice 1 } bind $btag $opts(mrgRght) { do-merge-choice 2 } bind $btag $opts(mrgLtoR) { do-merge-choice 12 } bind $btag $opts(mrgRtoL) { do-merge-choice 21 } } } } ############################################################################### # Bookmark handler: User toolbar-btns that Jump-Move to PARTICULAR diff regions # # Has a wealth of SUBCMDs (w/indiv arg fmts), including SOME to simply avoid # the need for yet MORE support fcns to encapsulate involved data derivations # -- makes the REMAINDER easier to read; Think: data-accessors w/better names # Thus: # Note: 'slv' is a GRID MANAGED window (eg: .win.a.b.c) # '{mn mx}' is a floating point value PAIR # most OTHER values are simply integers # # Primary-level (user) capabilities: # subcmd arg # ======= ======== # jump hNDX what a bookmark executes (jump to region # hNDX) # creat ?hNDX? creates a bookmark (dflt = CDR) # erase ?hNDX? destroys a bookmark (dflt = CDR) # scroll +/-num scroll the displaylist of bookmarks (num positions) # denote hNDX permit a user-specified identifier for chosen BMark # rptgen hNDX toggle inclusion for report generation purposes # eraseall destroys ALL bookmarks # # Internal-level functors: # mpop {hNDX x y} request popup-menu for designated hunk @ X,Y # set {mn mx} FEEDBACK from scrolled-widget stating current view # hNDX to reconfig when hunk-ndx/hunk-id relation chgs # adjSz col modify config AFTER ins/del of $col by eventloop # # Private primitives: (post-event-loop data accessors) to OBTAIN: # winCol slv grid column within master where $slv exists # viewSz slv Max VIEWABLE extent of provided-slaves MASTER ############################################################################### proc bkmark {cmd args} { global g w report # (apologies for our PRESUMPTION that 'grid info' produces a FIXED sequence) # Documentation only states indices 0 & 1 of ("-in $mstr -column $N -xx...) # Grid provides no OTHER means of NEEDED introspection switch -glob -- $cmd { winCol { # -> the grid-column index a MANAGED window object occupies return [lindex [grid info $args] 3] } viewSz { lassign [grid info $args] na mstr na col # -> pixel width of VIEWABLE $mstr area of given MANAGED slv return [lindex [grid bbox $mstr $col 0] 2] } adjSz { lassign $args col # Things to account for with the addition/loss of a Bmark button # (can involve grid configuration AND/OR scrolling considerations) # N.B> when called with "col<0", only re-analyzes for being resized # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # As a rule, you MUST NOT USE any of the above 'primitives' UNTIL # giving the eventloop a chance to spin AGAINST the changed item! # THATS why THIS subcmd is BEST invoked by "after idle"! # Make certain the scrolling canvas TRACKS where the last btn ENDS # (but also SNAG just that now NEW width value for further use) $w(bkmCvs) configure -scrollregion [concat 0 0 \ [set i [winfo reqwidth $w(bkmSF)]] \ [winfo reqheight $w(bkmSF)]] # Check if NOW is the time to toggle BOTH scroller btns visibility if {[winfo ismapped $w(toolbar).bSL]} { if {$i < ([bkmark viewSz $w(bkmCvs)] \ + (2 * [winfo reqwidth $w(toolbar).bSL])) } { grid remove $w(toolbar).bSL $w(toolbar).bSR } } elseif {$i > [bkmark viewSz $w(bkmCvs)]} { grid $w(toolbar).bSL $w(toolbar).bSR } # When 'col' is INTERIOR to the known grid, there is NOW a "gap" in # the COL numbering (because a btn WAS destroyed). Close that up # by shifting grid column assignments DOWNWARD of any ABOVE 'col' # (just like the DISPLAY did when it slid the graphics over) if {$col >= 0 && $col < [lindex [grid size $w(bkmSF)] 0] - 1} { foreach wdg [grid slaves $w(bkmSF)] { if {$col < [set j [bkmark winCol $wdg]]} { grid $wdg -column [incr j -1] } } } } jump { set hNDX $args # What the button actually does... GO there move $hNDX 0 1 } scroll { # For now -'units' is 1 button-widget size at a time # (unsure if something smaller ?1/4 btn? and FASTER is better) $w(bkmCvs) xview $cmd $args units } set { lassign $args Sfrac Efrac # Simply use scrolling feedback to (en/dis)able indiv scroller btns # - ensures auto-repeat STOPS firing when max travel is reached! # (uses 'catch' to map all the fractional junk to 'normal') set L(0.0) [set R(1.0) disabled] ; # <- keyed values that matter foreach {wdg val} "$w(bkmSL) $Sfrac $w(bkmSR) $Efrac" { if {[catch "set need \$[string index $wdg end]($val)"]} { set need normal } if {"$need"!= [$wdg cget -state]} {$wdg configure -state $need} } } creat { if {$args=={}} {set hNDX $g(pos)} {lassign $args hNDX} # Make a whole new bookmark if {! [winfo exists [set wdg $w(bkmSF).mark[hunk-id $hNDX]]]} { # Major graphic trick - Bookmark is both an image AND text... # Image is a graphics MASK with strategic transparent holes. # Text lays ON TOP of it. Size is CLAMPED per the image such # that Bgnd color ONLY shows thru holes, where not overlayed # by the text. Allows us to differentiate via color if/when # we so choose (likely in the future) toolbutton [frame $wdg -width [image width bkmImg] -bd 0 \ -height [image height bkmImg] ].btn -bd 0 \ -compound center -image bkmImg -text "\[$hNDX\]" \ -default disabled -command "bkmark jump $hNDX" \ -bg \#40d040 # Locking the frame size HALTS button from appealing for MORE # (excessive) text space, and only THEN can we shove the button pack propagate $wdg false ; # inside its EXACT sized jail! pack $wdg.btn # Doing Tooltip THIS way wont PopUp: simply reports as 'Status' # N.B> future possibility: # Should we WANT a 2nd category of bookmark, we only need # to change its -bg color, and perhaps call 'set_tooltip' # to OVERRIDE the 'statusbar binding' with a 'popup' one set g(tooltip,$wdg.btn) "\[$hNDX]: Jump to this diff region" # EACH Bmark takes the 'NEXT' avail column (but see cmd=erase) if {![set col [llength [grid slaves $w(bkmSF)]]] && [winfo reqwidth $w(bkmSF)] == 1} { # Apologies about weird if-test, but ONLY want this ONCE # per SESSION on the VERY FIRST Bmark! We are thus USING # the idea that TK originally creates the FRAME the btn # was JUST created into as 1x1, UNTIL the event-loop can # ACTUALLY get a chance to INSERT it (coming shortly). # Note that should the user ever REMOVE the LAST btn, # the FRAME actually RETAINS its THEN size (and does NOT # return to the original 1x1) PRESERVING our 1-time only. # # Now we want to set up for a full btns-worth of scrolling # We need the ACTUAL gridded size so emulate the '-padx 1' $w(bkmCvs) configure -xscrollincrement \ [expr {[winfo reqwidth $wdg] + 2}] } grid $wdg -row 0 -column $col -padx 1 # Finish-up by attaching the dynamic menu hook, then assessing # its addition AFTER implied events (object resizings) complete bind $wdg.btn "bkmark mpop $hNDX %X %Y" after idle bkmark adjSz $col } update-display } erase { if {$args=={}} {set hNDX $g(pos)} {lassign $args hNDX} # Destroy the given bookmark set hID [hunk-id $hNDX] if {[winfo exists [set wdg $w(bkmSF).mark$hID]]} { if {$hID in $report(BMrptgen)} { set report(bkmYN) 0 # Must not remain in the report content bkmark rptgen $hNDX } unset -nocomplain g(tooltip,$wdg.btn) # It makes a difference what grid COL this Bmark occupied... set col [bkmark winCol $wdg] bind $wdg.btn {} destroy $wdg # Finish-up AFTER implied events (object resizings) are handled after idle bkmark adjSz $col } update-display } eraseall { # Destroy ALL EXISTING bookmark(s) set bookmarks [info commands $w(bkmSF).mark*] # N.B> not to worry about "grid column' numbering -> goes to zero if {[llength $bookmarks] > 0} { foreach wdg $bookmarks { # Silly, but we need the frame to then KILL both IT + BTN if {[string match *.btn $wdg]} { continue } unset -nocomplain g(tooltip,$wdg.btn) bind $wdg.btn {} destroy $wdg } set report(BMrptgen) [list] after idle bkmark adjSz 0 } update-display } "[0-9]*[acd]*[0-9]" { lassign $args hNDX # Re-config diffnum <-> hunk-id relationship (ie. Re-number hunk) if {[winfo exists [set wdg $w(bkmSF).mark$cmd]]} { $wdg.btn config -text "\[$hNDX]" -bd 1 -pady 1 \ -command "bkmark jump $hNDX" set g(tooltip,$wdg.btn) \ [regsub {[0-9]+} $g(tooltip,$wdg.btn) $hNDX] bind $wdg.btn "bkmark mpop $wdg $hNDX %X %Y" } } denote { lassign $args hNDX # Ask for, then modify, the tooltip text per the users input set tID "tooltip,$w(bkmSF).mark[hunk-id $hNDX].btn" set i [string first ":" $g($tID)] set curVal [string range $g($tID) [expr $i+1] end] if [Prompt "Your annotation for Diff-region \[$hNDX]:" $curVal] { if {$curVal=={} && [string index $w(val.prompt) 0] != " "} { set w(val.prompt) " $w(val.prompt)" } set g($tID) [string replace $g($tID) $i end ":$w(val.prompt)"] } } rptgen { lassign $args hNDX # TOGGLE the participation of hNDX in a "Bkmark" report generation if {$hNDX != $report(bkmYN)} { # ALREADY present: must remove it set i [lsearch -exact $report(BMrptgen) [hunk-id $hNDX]] set report(BMrptgen) [lreplace $report(BMrptgen) $i $i] } else { lappend report(BMrptgen) [hunk-id $hNDX] } } mpop { lassign $args hNDX x y # Empty, Config, then popup, the BMark menu for the specific button $w(bkmenu) delete 0 end $w(bkmenu) add command \ -label "annotate" -command "bkmark denote $hNDX" set report(bkmYN) \ [expr {[hunk-id $hNDX] in $report(BMrptgen) ? $hNDX : 0}] $w(bkmenu) add checkbutton -variable report(bkmYN) -onvalue $hNDX \ -label "in-report" -command "bkmark rptgen $hNDX" tk_popup $w(bkmenu) $x $y } } } ############################################################################### # Customize the display (among other things). # # N.B> Editting within the 'Behavior' category REQUIRES the use of a local GRAB # which, in turn, is used to BLOCK access to focus-Tabbing into major controls # of the dialog (Categories, Save, and Help buttons) PREVENTING keyboard invokes # of such controls. That same "grab aversion" CAN ALSO be caused by usage of a # "combobox" (which MAY do a GLOBAL grab) in whichever category is then active. ############################################################################### proc customize {} { global g w pref opts tmpopts tcl_platform if {![Dialog NONMODAL $w(prefs)]} { wm title $w(prefs) "$g(name) Preferences" wm transient $w(prefs) . wm group $w(prefs) . wm withdraw $w(prefs) # we don't want the window to be deleted, just hidden from view wm protocol $w(prefs) WM_DELETE_WINDOW {Dialog dismiss $w(prefs)} # the button frame... # N.B> Unusual 'takefocus' prevents the Behavior tab from letting # the keyboard Tab-traverse INTO these buttons until AFTER a local # grab is no longer in-force ON that particular tab-page! frame $w(prefs).buttons -bd 0 button $w(prefs).buttons.dismiss -width 8 -text "Dismiss" \ -command {prefdismiss $w(prefs)} button $w(prefs).buttons.apply -width 8 -text "Apply" \ -command {prefapply $w(prefs).buttons.apply} button $w(prefs).buttons.save -width 8 -text "Save" \ -command {prefsave $w(prefs).buttons.save} -takefocus \ {apply {wdg { return [expr {[grab current $wdg]=={}}] }}} button $w(prefs).buttons.help -width 8 -text "Help" \ -command {do-help-prefs} -takefocus \ {apply {wdg { return [expr {[grab current $wdg]=={}}] }}} pack $w(prefs).buttons -side bottom -fill x pack $w(prefs).buttons.dismiss -side right -padx 10 -pady 5 pack $w(prefs).buttons.help -side right -padx 10 -pady 5 pack $w(prefs).buttons.save -side right -padx 1 -pady 5 pack $w(prefs).buttons.apply -side right -padx 1 -pady 5 # a series of radiobuttons to act as a poor mans notebook tab frame $w(prefs).notebook -bd 0 pack $w(prefs).notebook -side top -fill x -pady 4 set pagelist {} # The relief makes these work, so we don't need to use the selcolor # Radiobuttons without indicators look rather sucky on MacOSX, # so we'll tweak the style for that platform # These are also subject to non-Tab-traversal when grab is active set indicatoron [expr {$w(wSys) == "aqua"}] foreach page {General Display Behavior Appearance} { set frame $w(prefs).f$page lappend pagelist $frame set rb $w(prefs).notebook.f$page radiobutton $rb -command "setPrefPage $frame" \ -selectcolor $w(background) \ -variable g(prefPage) -value $frame -height 2 -text $page \ -indicatoron $indicatoron -borderwidth 1 -takefocus \ {apply {wdg { return [expr {[grab current $wdg]=={}}] }}} pack $rb -side left frame $frame -bd 2 -relief groove -width 400 -height 300 } # this is an option that we support internally, but don't give # the user a way to directly edit (right now, anyway). But we # need to make sure tmpopts knows about it set tmpopts(customCode) $opts(customCode) # General # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # set frame $w(prefs).fGeneral set row 0 foreach key {diffcmd ignoreblanksopt tmpdir editor ignoreRegexLnopt filetypes geometry } { label $frame.l$row -text "$pref($key): " -anchor w set tmpopts($key) $opts($key) if {$key == "ignoreRegexLnopt" || $key == "filetypes"} { ::combobox::combobox $frame.e$row -width 50 \ -command "editLstPref $key" -listvar tmpopts($key) } else { entry $frame.e$row -width 50 -bd 2 -relief sunken \ -textvariable tmpopts($key) } grid $frame.l$row -row $row -column 0 -sticky w -padx 5 -pady 2 grid $frame.e$row -row $row -column 1 -sticky ew -padx 5 -pady 2 incr row } # this is just for filler... label $frame.filler -text {} grid $frame.filler -row $row incr row # Option fields # Note that the order of the list is used to determine the layout. # So, if adding something to the list pay attention to what it affects. # # Remaining layout is a 2-col, row-major order (ie. cols vary fastest) # an 'x' means an empty column; a '-' means an empty row # (Note: rows must be fully filled - even if that means a trailing 'x') set col 0 foreach key { ignoreblanks autocenter - ignoreEmptyLn autoselect - ignoreRegexLn autoSrch syncscroll scmPrefer - predomMrg x} { if {$key != "x"} { if {$key == "-"} { frame $frame.f${row} -bd 0 -height 4 grid $frame.f${row} -row $row -column 0 -padx 20 -pady 4 \ -columnspan 2 -sticky nsew set col 1 ;# forces NEXT column to zero and increments row } else { set tmpopts($key) $opts($key) if {"$key" == "scmPrefer"} { set f [frame $frame.c${row}$col -bd 0] label $f.l -text "$pref($key): " -anchor w pack $f.l -side left # Hmm, annoying - we need two of these, but want to # treat the value as the list of BOTH - # this'll take some work foreach {val} {0 1} { # set it to reassemble values when EITHER changes spinbox $f.s$val -width 7 -repeatinterval 400 \ -values [list None {*}$g(scmS) Auto] \ -command "apply {{ndx v} { global tmpopts lset tmpopts($key) \$ndx \$v }} $val %s" -state readonly eval $f.s$val set [lindex $tmpopts($key) $val] pack $f.s$val -side top } } elseif {"$key" == "predomMrg"} { set f [frame $frame.c${row}$col -bd 0] label $f.l -text "$pref($key): " -anchor w pack $f.l -side left foreach {nam val} {Left 1 Right 2} { radiobutton $f.r$val -text $nam -value $val \ -variable tmpopts($key) pack $f.r$val -side left } } else { checkbutton $frame.c${row}$col -indicatoron true \ -text "$pref($key)" -onvalue 1 -offvalue 0 \ -variable tmpopts($key) } grid $frame.c${row}$col -row $row -column $col \ -sticky w -padx 5 } } if {![set col [expr {$col ? 0 : 1}]]} { incr row } } # add validation to enable/disable BOTH 'ignore(blanksopt/RegexLnopt)' # and then initialize them into agreement trace add var tmpopts(ignoreblanks) write [list alignState $frame.e1] trace add var tmpopts(ignoreRegexLn) write [list alignState $frame.e4] alignState $frame.e1 tmpopts ignoreblanks write alignState $frame.e4 tmpopts ignoreRegexLn write # The bottom row and right col should stretch to take up any extra room grid columnconfigure $frame 0 -weight 0 grid columnconfigure $frame 1 -weight 1 grid rowconfigure $frame $row -weight 1 # pack this window for a brief moment, and compute the window # size. We'll do this for each "page" and find the largest # size to be the size of the dialog pack $frame -side right -fill both -expand y update idletasks set maxwidth [winfo reqwidth $w(prefs)] set maxheight [winfo reqheight $w(prefs)] pack forget $frame # Appearance # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # set frame $w(prefs).fAppearance set row 0 foreach key {textopt difftag deltag instag chgtag currtag bytetag inlinetag overlaptag} { set tmpopts($key) $opts($key) label $frame.l$row -text "$pref($key): " -anchor w entry $frame.e$row -textvariable tmpopts($key) -bd 2 -relief sunken grid $frame.l$row -row $row -column 0 -sticky w -padx 5 -pady 2 grid $frame.e$row -row $row -column 1 -sticky ew -padx 5 -pady 2 incr row } # tabstops are placed after a little extra whitespace, since it is # slightly different than all of the other options (ie: it's not # a list of widget options) frame $frame.sep$row -bd 0 -height 4 grid $frame.sep$row -row $row -column 0 -stick ew -columnspan 2 \ -padx 5 -pady 2 incr row set key "tabstops" set tmpopts($key) $opts($key) label $frame.l$row -text "$pref($key):" -anchor w entry $frame.e$row -textvariable tmpopts($key) -bd 2 -relief sunken \ -width 3 grid $frame.l$row -row $row -column 0 -sticky w -padx 5 -pady 2 grid $frame.e$row -row $row -column 1 -sticky w -padx 5 -pady 2 incr row # Option fields # Note that the order of the list is used to determine the layout. # So, if adding something to the list pay attention to what it affects. # # Remaining layout is a 2-col, row-major order (ie. cols vary fastest) # an 'x' means an empty column; a '-' means an empty row # (Note: rows must be fully filled - even if that means a trailing 'x') set col 0 foreach key {inform adjcdr mapins mapchg mapdel mapolp} { if {$key != "x"} { if {$key == "-"} { frame $frame.f${row} -bd 0 -height 4 grid $frame.f${row} -row $row -column 0 -padx 20 -pady 4 \ -columnspan 2 -sticky nsew set col 1 ;# forces NEXT column to zero and increments row } else { # button 'active' bg shows color as contrasted w/Txt fg set tmpopts($key) $opts($key) set b $frame.b${row}$col button $b -text "$pref($key)" -command "clrpick $b $key" \ -activeforeground [$w(LeftText) cget -fg] \ -activebackground $tmpopts($key) grid $b -row $row -column $col -sticky ew -padx 5 -pady 2 } } if {![set col [expr {$col ? 0 : 1}]]} { incr row } } # a tiny bit of validation, so user can only enter numbers for tabwidth trace add var tmpopts(tabstops) write [list validate integer] # The bottom row and right col should stretch to take up any extra room grid columnconfigure $frame 0 -weight 0 grid columnconfigure $frame 1 -weight 1 grid rowconfigure $frame $row -weight 1 pack $frame -side right -fill both -expand y update idletasks set maxwidth [max $maxwidth [winfo reqwidth $w(prefs)]] set maxheight [max $maxheight [winfo reqheight $w(prefs)]] pack forget $frame # Display # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # set frame $w(prefs).fDisplay # Option fields # Note that the order of the list is used to determine the layout. # So, if adding something to the list pay attention to what it affects. # # Remaining layout is a 2-col, row-major order (ie. cols vary fastest) # an 'x' means an empty column; a '-' means an empty row # (Note: rows must be fully filled - even if that means a trailing 'x') set row 0 set col 0 foreach key { toolbarIcons fancyButtons - showln tagln - showcbs tagcbs - showmap colorcbs - tagtext showinline1 x showinline2 - showlineview x } { if {$key != "x"} { if {$key == "-"} { frame $frame.f${row} -bd 0 -height 4 grid $frame.f${row} -row $row -column 0 -padx 20 -pady 4 \ -columnspan 2 -sticky nsew set col 1 ;# forces NEXT column to zero and increments row } else { set tmpopts($key) $opts($key) checkbutton $frame.c${row}${col} -indicatoron 1 -onval 1 \ -offval 0 -text "$pref($key)" -variable tmpopts($key) # Manage each widget EXCEPT 'fancybuttons' on MacOS 'Aqua' if {$key != "fancyButtons" || $w(wSys) != "aqua"} { grid $frame.c${row}$col -sticky w -padx 5 \ -row $row -column $col } } } if {![set col [expr {$col ? 0 : 1}]]} { incr row } } # add validation to ensure only one of the showinline* options is set trace add var tmpopts(showinline1) write "validate-inline showinline1" trace add var tmpopts(showinline2) write "validate-inline showinline2" # The bottom row and right col should stretch to take up any extra room grid columnconfigure $frame 0 -weight 0 grid columnconfigure $frame 1 -weight 1 grid rowconfigure $frame $row -weight 1 pack $frame -side right -fill both -expand y update idletasks set maxwidth [max $maxwidth [winfo reqwidth $w(prefs)]] set maxheight [max $maxheight [winfo reqheight $w(prefs)]] pack forget $frame # Behavior (aka bindings) # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # set frame $w(prefs).fBehavior # Option fields # Note that the order of the list is used to determine the layout. # So, if adding something to the list pay attention to what it affects. # # Remaining layout is a 2-col, row-major order (ie. cols vary fastest) # an 'x' means an empty column; a '-' means an empty row # (Note: rows must be fully filled - even if that means a trailing 'x') set row 0 set col 0 foreach key {Navigation navFrst x navLast x navNext x navPrev x navCntr - Merge\ Choice mrgLeft x mrgRght x mrgLtoR x mrgRtoL - Generic genEdit x genFind x genNxfile x genPvfile x genRecalc x genXit } { if {$key != "x"} { if {$key == "-"} { frame $frame.f${row} -bd 0 -height 10 grid $frame.f${row} -row $row -column 0 -padx 20 -pady 4 \ -columnspan 2 -sticky nsew set col 1 ;# forces NEXT column to zero and increments row } else { set b $frame.b${row}$col if {$col} { set tmpopts($key) $opts($key) label $b -text $pref($key) -takefocus 1 -relief sunken\ -highlightthickness 1 bind $b "getKey view %W $key" bind $b "getKey prep %W $key" bind $b "getKey rlse %W $key" } else { label $b -text $key -width 20 } grid $b -row $row -column $col -sticky ew -padx 5 -pady 2 } } if {![set col [expr {$col ? 0 : 1}]]} { incr row } } # The bottom row and right col should stretch to take up any extra room grid columnconfigure $frame 0 -weight 0 grid columnconfigure $frame 1 -weight 1 grid rowconfigure $frame $row -weight 1 pack $frame -side right -fill both -expand y update idletasks set maxwidth [max $maxwidth [winfo reqwidth $w(prefs)]] set maxheight [max $maxheight [winfo reqheight $w(prefs)]] pack forget $frame # # # # # # # Assemble all the page/Tabs and Display one # # # # # # # setPrefPage [set g(prefPage) $w(prefs).fGeneral] # compute a reasonable FIRST location for the window... centerWindow $w(prefs) "$maxwidth $maxheight" } # FINALLY - display it! Dialog show $w(prefs) } ############################################################################### # Hotkey-edit event handler to display/capture/decode/establish global hotkeys # N.B> $wdg is EITHER the 'label' or an 'entry' depending on HOW FAR the # edit process has progressed - pay attention to binds, focus, and grabs # NOTE: does NOT "apply" the new binding - that happens during 'prefapply' ############################################################################### proc getKey {cmd wdg key args} { global w tmpopts opts pref switch $cmd { view { # Simply SHOW the user what the binding currently is $wdg config -text $tmpopts($key) set w(savLblBg) [$wdg cget -background] } prep { $wdg config -bg $opts(inform) # N.B> magic numbers to AVOID responding to Modifier keys (we hope) # (see Tcl manpage 'keysyms' to decode values) bind $wdg "if {(%N<65505 || %N>65518) && (%N!=65407)} { getKey edit %W $key %s %K}" focus $wdg ;# Make sure next keystroke is SEEN by above binding } rlse { # Perhaps (maybe?) needs to come here as well as # (ie. when we unmap it during 'edit' - or does that happen anyway?) $wdg config -text $pref($key) -bg $w(savLblBg) bind $wdg {} } edit { # Hide the label widget and pop an entry widget to take its place # (LOADING said entry widget with the VERY NEXT KEYSTROKE) # Entry widget NAME simply appends 'E' to the Label it replaces set tmpopts($key) [keyMods {*}$args] entry ${wdg}E -bg $opts(inform) -textvar tmpopts($key) grid ${wdg}E {*}[grid info $wdg] focus ${wdg}E ;# Trade focus to newly created widget grid remove $wdg ;# THEN Unmap (but dont forget) Label # ( N.B> this 'deactivates' its attached binding) update idletask # Now ensure "editting" is TERMINATED if user tries to go elsewhere bind ${wdg}E "getKey insert %W $key {*}$args" bind ${wdg}E "getKey cancel %W $key" bind ${wdg}E "getKey chkfocs %W $key {*}$args" bind ${wdg}E "getKey chkcncl %W $key %X %Y" # Buttonpress is tricky - COULD depend on WHERE it occurs ... # thus grab the pointer to make sure WE get to evaluate it # (should be SAFE -because- current toplevel is NOT MODAL) grab ${wdg}E } chkfocs { Dbg "$cmd $key as $tmpopts($key) via $wdg" # N.B> Only ${wdg}E widgets should call this subcommand # While not as critical for "Click-to-Type", "Focus-follows-Mouse" # could prematurely trigger a focus-loss in mid-edit which would # (due to trying to support focus-Tabbing AS an 'accept/insert'), # be MISTAKEN as such. Thus TRY to differentiate (if possible). # # (TK ?? Un-documented: [focus] reports EMPTY even when mouse # is moved OUT (in FfM mode) of the current Toplevel YET stays # WITHIN the "." Toplevel; But WILL report a value for a NEW # current Toplevel (such as the popup Help dialog): strange?!! # However, as the Help dialog is then FROZEN by the grab, # it becomes useless, thus we now prevent it from popping up # (which obviates any need to check for and deal with it NOW) # # Whatever - so if a Focus-Tab has occurred, we SHOULD see a new # window reported and we can therefore ACCEPT the pending edit if {[set win [focus -displayof [winfo toplevel $wdg]]] != {}} { Dbg " focus went to $win" # Presumption is user just used a [Tab] to complete the edit getKey insert $wdg $key {*}$args } } chkcncl { Dbg "$cmd $key as $tmpopts($key) via $wdg" # Decide if user is simply MOVING the entry insertcursor or DOING # something un/related IMPLYING we should CANCEL (or ACCEPT?) it. # N.B> Only ${wdg}E widgets should call this subcommand # SKIP: "Save" (is pointless); "Help" would be hung by the grab # N.B> ${wdg}E MAY no longer exist (if cancelled by Dismiss here) if {[winfo exists $wdg] && "$wdg" != "[set win [winfo containing {*}$args]]"} { # Somewhere else ... must we cancel? if {"$win" == "$w(prefs).buttons.dismiss"} { Dbg " Was $win - need to cancel" getKey cancel $wdg $key $win invoke return -code break } elseif {"$win" == "$w(prefs).buttons.apply"} { # sortof makes sense, if you think of it as a "shortcut" Dbg " Was $win - need to accept" getKey insert $wdg $key $win invoke return -code break } # Hmmm, we COULD notice a click on a DIFFERENT bind target and # cancel/switch (or accept/switch) to IT, but lets NOT for now # FYI - method: "event generate" TO the new widget window, # but after doing WHAT (accept/cancel)? } # Everything else should be fine. If we are still within the prefs # toplevel, the grab is in effect (pretty sure that applies to our # main windows as well) so NOTHING should happen as it wont ever be # DELIVERED anywhere else. However, if its outside the TOOL, we # WONT KNOW it, because the grab was NOT global...so we simply # pause and wait for the user to get back to us. } cancel - insert { Dbg "$cmd $key as $tmpopts($key) via $wdg (being destroyed)" # N.B> Only ${wdg}E widgets should call these subcommands if {$cmd != "cancel"} { # Re-instate angle-brackets (even if user TRIED to add them) # (Note: also prevents specifying virtual events) set tmpopts($key) "<[string map {< {} > {}} $tmpopts($key)]>" } else { set tmpopts($key) $opts($key) } # Whack the entry widget and RESTORE the LABEL widget back in place # (Derives original Label widget name FROM the given Entry widget) # Grab is implicitly released as its target ($wdg) is killed destroy $wdg grid [string replace $wdg end end] update idletask } } } ############################################################################### # Presumptious little routine to decode a Keypress into ALL its contributors ############################################################################### proc keyMods {state key} { global w # List of 'power-of-2' bit masks is used to recognize the modifers: # N.B> Certain bit patterns (Alt) were found as platform specific (win32)? foreach {bit nam} { 131072 "Alt" 128 "Mod5" 64 "Mod4" 32 "Mod3" 16 "Mod2" 8 "Mod1" 4 "Control" 2 "Lock" 1 "Shift" } { if {$state & $bit} { lappend modifiers $nam } } # MacOS doesn't seem to LIKE having 'Key' as a modifier - skip it... UNLESS # its a single DIGIT which WOULD be MISTAKEN as a Button; instead of a Key! if {$w(wSys) != "aqua" || [string match {[0-9]} $key]} { lappend modifiers Key $key } { lappend modifiers $key } # Platforms apparently define "preferred" names for certain modifiers # Some of this is platform derived, others (Aqua) was manpage derived set map(win32) [list "Mod1" "Num" "Mod3" "Scroll"] set map(aqua) [list "Mod1" "Command" "Mod2" "Option" ] set map(x11) [list "Mod1" "Alt" "Mod3" "Scroll"] return [string map $map($w(wSys)) [join $modifiers "-"]] } ############################################################################### # align status of passed widget to agree with passed var($index) boolean value ############################################################################### proc alignState {widget name index op} { upvar $name var $widget configure -state [expr {$var($index) ? "normal" : "disabled"}] } ############################################################################### # A generalized preferences entry-field data-type validator ############################################################################### proc validate {type name index op} { global tmpopts # if we fail the check, attempt to do something clever if {![string is $type $tmpopts($index)]} { bell switch -- $type { integer { regsub -all {[^0-9]} $tmpopts($index) {} tmpopts($index) } default { # this should never happen. If you use this routine, # make sure you add cases to handle all possible # values of $type used by this program. set tmpopts($index) "" } } } } ############################################################################### # Specialized color-picker invoked by button (feedback to specific button -bg) ############################################################################### proc clrpick {wdg key} { global pref tmpopts set color [tk_chooseColor -initialcolor [$wdg cget -activebackground] \ -parent [file rootname $wdg] -title "Choose $pref($key)"] if {"$color" != ""} { $wdg configure -activebackground [set tmpopts($key) $color] } } ############################################################################### # Manage user interaction with any pref represented via a 'list of values' ############################################################################### proc editLstPref {key args} { global pref tmpopts # Empty values simply have no effect and are ignored # (we sortof use it as feedback that we "accepted" the add/delete) foreach {wdg value} $args { if {![string length "[string trim "$value"]"]} {return} } # Ugh - the combobox widget apparently has a *global* GRAB in progress ... # So we CANT really popup modal dialogs for confirmations, etc. # Instead, we will ENCAPSULATE the notices/feedback/actions to occur # *after* this callback (and combobox) are DONE (and the grab is gone) # # N.B> "subst + backslashing" is needed to resolve & embed LOCAL vars # Confirm requests to DELETE from the list if {[set ndx [lsearch -exact $tmpopts($key) "$value"]] >= 0} { after idle [subst { if {{ok} == \[tk_messageBox -type okcancel -icon question \ -title {Please Confirm} -parent [file rootname $wdg] \ -message "Remove this entry from the\n'$pref($key)' list ?" \ -default cancel ]} \ { set tmpopts($key) \[lreplace \$tmpopts($key) $ndx $ndx]; \ editLstFeedback $wdg { R e m o v e d} } }] } else { # Possibly validate the FORM of the specific entry before ADDING it if {"$key" == "filetypes" && [llength "$value"] != 2} { after idle [subst { tk_messageBox -type ok -title {Syntax error} -icon info \ -parent [file rootname $wdg] -detail {(not added)} \ -message "Format should be '{filetype label} .extension'" }] } else { after idle [subst { lappend tmpopts($key) {$value} ; \ editLstFeedback $wdg { A d d e d} }] } } } ############################################################################### # Pure unadulterated GUI fluff (lets user KNOW their edit was accepted) ############################################################################### proc editLstFeedback {wdg msg} { # Pretend to enter a new value (but dont let the command fire) ... then # 1250ms later, clear with an EMPTY value (and LET it fire w/no effect) $wdg configure -commandstate disabled $wdg configure -value "$msg" after 1250 "$wdg configure -commandstate normal -value {}" } ############################################################################### # Emulate SEMI-radio-button behavior: only 1 can be 'on', BUT BOTH may be 'off' ############################################################################### proc validate-inline {option name index op} { global tmpopts if {$tmpopts($index)} { if {$index == "showinline1"} { set tmpopts(showinline2) 0 } elseif {$index == "showinline2"} { set tmpopts(showinline1) 0 } } } ############################################################################### # Finalize packing the Preferences dialog for the largest "tab" overlay # and designate which to actually display ############################################################################### proc setPrefPage {which} { global w pack forget $w(prefs).fGeneral pack forget $w(prefs).fAppearance pack forget $w(prefs).fDisplay pack forget $w(prefs).fBehavior pack $which -side right -fill both -expand y } ############################################################################### # Quickly spin through all the prefs and look exclusively for any that WERE # editted, yet NEVER applied. Request permission to remove them and base the # decision to erase them AND dismissal of the dialog on that answer ############################################################################### proc prefdismiss {prefwin} { global pref opts tmpopts # Anything here that was UN-"Apply"-ed ? foreach key [array names pref] { if {"$tmpopts($key)" ne "$opts($key)"} { if {![info exists YN]} { set YN [popmsg "You made UN-APPLIED edits !\n\n Remove them?"\ "Please confirm" question yesno $prefwin] if {$YN == "no"} { return } } set tmpopts($key) "$opts($key)" } } if {![info exists YN] || $YN == "yes"} {Dialog dismiss $prefwin} } ############################################################################### # Apply customized preferences ($WdG is only provided when invoked from dialog) # Expects $opts() holds CURRENT settings; $tmpopts() ALL (possibly CHGD) values ############################################################################### proc prefapply {{WdG {}}} { global g w pref opts tmpopts set feedback green ;# Presumed 'status' of updating prefs (AS A WHOLE) set prevgrid [wm grid .] # Geom-manager 'propagation' is generally OFF within w(client) to force any # sizing changes (particularly subtle ones such as font adjustments caused # by Text tagging) to "trade" among its OWN widgets, instead of "Appealing" # for more space from the toplevel. Its ALSO critical to our EMULATION of a # 'pane window' relation between the L/R Txtwins (SANS a widget): it too # needs a hard-stop confined area to work properly. YET, we come through # this 're-cfg' code not ONLY when the USER asks us to, but ALSO during the # INITIAL startup BEFORE we have ANY IDEA how big anything SHOULD be, and # thus appealling TO the Toplevel is actually a NECESSITY... # # SO we USE the fact that AT startup, propagation is NOT YET "OFF" # (it will BECOME SO after we return from that SPECIFIC startup call) # # HOWEVER - the behavior we WANT is to prevent the INITIAL startup from # producing a window LARGER than the current screen - even if we have to # LIMIT the users "preferred" opts(geometry) value regarding Txtwin sizes # # Afterward, the Toplevel will be modifiable ONLY by the USER, yet it # should ALWAYS operate in a 'gridded' resize-mode. This gets insidious # when considering that some 'prefs' might control the visibility of client # elements which could ALTER the amount of Txtwin real-estate, and thus # WOULD modify the "grid defn" for that Toplevel. But there is a CATCH: # # TYING a Txtwin *into* its Toplevel (via the Txtwdg "-setgrid 1" option) # ONLY WORKS PROPERLY if IT is the ONLY widget to absorb any resizing! # # It turns out we have one Toplevel that DOES (merge) and one NOT (client)! # Yet there is a STOOPID reason we still want to use "-setgrid 1" in BOTH # cases - and that is the Txtwdg calculates its OWN IDEA of what the grid # INCREMENT size (in pixels) is for the loaded font! Something we can only # approximate by "measuring an entire alphabet" and divide by 26 - which # works - but is clearly "English based" unlike all user-provided files to # be displayed. SO WE ARE BANKING on TK to "get it right" by LETTING it # THINK (for a moment) that just ONE of the L/R (client) Txtwdgs will be # TIED to the Toplevel **JUST** so we can get that Font analysis performed. # Then we will sever the connection, but USE the computed pixel value, and # install NEW Toplevel 'gridding' parameters ourselves! What a PITA!! # N.B> Despite being described here, this all MOSTLY happens @ the end. if {! [file isdirectory $tmpopts(tmpdir)]} { popmsg "Invalid temporary directory:\n$tmpopts(tmpdir)\nReverted ..." \ $w(prefs) set tmpopts(tmpdir) $opts(tmpdir) set feedback red } # (Possibly) rebalance the Txtwin(s): # Effectively CANCELs any EXISTING L/R 'pane' adjustments, # and RESULTs in re-centering the DiffMap (if displayed) # N.B> Subtle impact: Should cause L/R Txtwdg WIDTHs to become IDENTICAL! grid columnconfigure $w(client) {0 2} -weight 100 -uniform a # This may look contrived (see discussion above for explanation) ... # ... the point is that IF it fails for ONE, it LIKELY fails for ALL, # so there is little point to "fail and reset" over-and-over foreach wdg {Left merge Right Bottom} toplnk {1 1 0 0} { # Should this Txtwdg LINK to its Toplevel (for gridded resizes)? if {$toplnk} {set toplnk "-setgrid 1"} {set toplnk ""} # N.B> ensure 'toplnk' has every chance of becoming set (when active): # Even *if* USERS input is invalid (to preserve later code semantics) if {[catch "$w(${wdg}Text) configure $toplnk $tmpopts(textopt)"]} { popmsg "Invalid text widget setting:\n\n'$tmpopts(textopt)'" \ $w(prefs) # Error recovery - restore PRIOR settings (+ DONT do any further!) $w(${wdg}Text) configure {*}$opts(textopt) set tmpopts(textopt) $opts(textopt) set feedback red break } } # Make certain the (now established) Text FG/BG colors are PUSHed into # attrs needed to visibly see their focus-highlight border, and the BG # of their adjoining Info windows (can just get seed values from Left) set fg [$w(LeftText) cget -foreground] set bg [$w(LeftText) cget -background] foreach txtwin {Left Right merge} { $w(${txtwin}Text) configure -highlightb $bg -highlightc $fg $w(${txtwin}Info) configure -background $bg } #NOTE: This loop is basically "testing" each NEW tag setting for syntactic # validity (as well as 'installing' them). H O W E V E R ... # it is IMPERATIVE they PROCESS (and thus remain) in PRECEDENCE order # already ESTABLISHED @creation time foreach tag [lsearch -all -inline [$w(LeftText) tag names] "*tag"] { foreach win [list $w(LeftText) $w(RightText)] { if {[catch "$win tag configure $tag $tmpopts($tag)"]} { popmsg "Invalid settings for \"$pref($tag)\":\n\ \n'$tmpopts($tag)' is not a valid option string\nReverted..." \ $w(prefs) # if one fails, restore its prior 'good' setting eval "$win tag configure $tag $opts($tag)" set tmpopts($tag) $opts($tag) set feedback red } } } # Same for the (only) tag for the line-comparison widget ... if {[catch "$w(BottomText) tag configure diff $tmpopts(bytetag)"]} { popmsg "Invalid settings for \"$pref(bytetag)\":\n\ '$tmpopts(bytetag)' is not a valid option string.\nReverted..." \ $w(prefs) # Again, if it fails, restore the prior 'good' setting eval "$w(BottomText) tag configure diff $opts(bytetag)" set tmpopts(bytetag) $opts(bytetag) set feedback red } # ... but if that tag contained a FONT request, we want to elevate that # font to the entire widget (lest it obscure the windows basic purpose) # INCLUDING the possible need to re-cfg the window height to match if {[set bHiFont [$w(BottomText) tag cget diff -font]] ne ""} { if {$bHiFont ne [$w(BottomText) cget -font]} { $w(BottomText) configure -font "$bHiFont" -height 2 } } # tabstops require a little extra work. We need to figure out the width of # an "m" in the widget's font, then multiply that by the tab stop width. set cwidth [font measure [$w(LeftText) cget -font] "m"] set tabstops [expr {$cwidth * $tmpopts(tabstops)}] $w(LeftText) configure -tabs $tabstops $w(RightText) configure -tabs $tabstops $w(mergeText) configure -tabs $tabstops # But, for the bottom text widget, the tabstop is adjusted to take into # consideration the two bytes PREFIXED to each line (ie: "< " or "> "). $w(BottomText) configure -tabs \ [list [expr {$tabstops+($cwidth*2)}] [expr {2*$tabstops+($cwidth*2)}]] # Set remaining 'opts' to the values from 'tmpopts' # N.B> any ERRORS to this point have all been REVERTED to prior values # PAY ATTENTION: # Most options represent "data state" values and can simply be 'set', # that INCLUDES those already processed (above) which WILL be recorded; # but some are TRANSITION (or 'edge') triggered and thus must notice # when they are being CHANGED, more so than JUST their final value. # # With such 'edge' options, SEQUENCE *does* make a difference, # such as the 'ignore...' group, which could force a REdiff and thus # influence OTHER settings, such as skipping tasks which ultimately get # redone anyway (such as inline-diff processing, which ITSELF has its # own sequence issue [unwinding 2 NEARLY mutually exclusive values]). # We also want to avoid the time it can take to RE-tag everything # (via a call to 'remark-diffs') if we dont need to - so we have to # watch for CHANGES among the options that *could* have altered tags. # # BUT WE CANT assess *all* of that until we've seen ALL the settings # (or worse, write code to handle each COMBINATION that might occur) # # SO - we 'pre-arrange' those settings having their OWN issues into a # sub-order we can depend on (to write the logic ONE way), and then post # flag values we can assess AFTERWARD to enforce the larger precedence # issues - thus avoiding the "excess" work alluded to above. # # (N.B.: when the startup coding invokes 'prefapply', it just COPIES # 'opts' into 'tmpopts' first - as such, transitions will NEVER exist.) # First we need an 'inversion' primitive to access meta-state values ... set OTHER(showinline1) showinline2 set OTHER(showinline2) showinline1 # ... next, preload any keys needing their OWN precedence order ... # (Reason: chgd content of an '...opt' field that IS [and WILL] remain # in use, OR turning the entire category ON/OFF ) lappend keys ignoreEmptyLn ignoreRegexLnopt ignoreRegexLn \ ignoreblanksopt ignoreblanks # (Reason: switching among inline algorithms, including to ON or OFF) lappend keys showinline1 showinline2 # (followed by EVERY PREF defined - BUT we only process each ONCE) # N.B> makes certain we dont MISS any (as has happened before... ) lappend keys {*}[array names pref] set ONCE {} # ... finally, init the flags we need to derive - and then GET TO IT!! set remap [set remark 0] ;# defaulted as: do NOT remap or remark set inlActn {} ;# NOR 'compute-inlines' or force a Diff if {[info exists g(redoDiff)]} { set redoDiff $g(redoDiff) ;# UNLESS that rediff was PENDING!!! } { set redoDiff {} } foreach key $keys { # What (if anything) is transitioning ? if {$key ni $ONCE && "$tmpopts($key)" ne "$opts($key)"} { switch $key { "geometry" { # More of a syntax-chk validation than a transition issue if {2 > [scan $tmpopts(geometry) "%dx%d" na na]} { popmsg "Invalid geometry:\n$tmpopts(geometry)\n \ Reverted..." $w(prefs) "Improper syntax..." set tmpopts(geometry) $opts(geometry) set feedback red } } "ignoreEmptyLn" { set redoDiff $key ;# either transition (on/off) counts } "ignoreRegexLnopt" - "ignoreblanksopt" { # Does anyone appreciate all this work for 'auto-Diff'ing? # Here we cover changes made in the "...opt" fields while # REMAINING in a (non-transitional) 'ON' state... set key2 [string range $key 0 end-3] if {$tmpopts($key2) && $opts($key2)} {set redoDiff $key2} } "ignoreRegexLn" - "ignoreblanks" { # Turning these 'ON' requires REFERING to a non-null opt # (N.B> depends on "...opt" ALREADY being processed) if {$tmpopts($key)} { # Unfortunately each has its own notion of 'non-null' switch ${key}opt { "ignoreblanksopt" { if {"[string trim $opts(${key}opt)]" == ""} { set tmpopts($key) 0} {set redoDiff $key } } "ignoreRegexLnopt" { if {![llength $opts(${key}opt)]} { set tmpopts($key) 0} {set redoDiff $key } } } } else {set redoDiff $key} ;#but turning 'OFF': gauranteed } "showinline1" - "showinline2" { # (meta-logic here only APPEARS convoluted) # Basically has only 3 possibilities: # # ... a DOUBLE transition: MUST select the eventual 'ON' if {"$tmpopts($OTHER($key))" ne "$opts($OTHER($key))"} { if {$tmpopts($key)} { # THIS opt *is* the 'ON', but must then PRESET # the other OFF (to eliminate the 2nd transition) set inlActn "compute-inlines $key" set opts($OTHER($key)) 0 } # (assist "compute-inlines" with a NEEDED data flush) array unset g "inline,*" # ... a single OFF -> ON transition # (or ALLOWED 2nd transition from prior DOUBLE) } elseif {$tmpopts($key)} { set inlActn "compute-inlines $key" # ... a single ON -> OFF transition } else { set inlActn "compute-inlines {}" } } "genEdit" - "genFind" - "genNxfile" - "genPvfile" - "genRecalc" - "genXit" - "navFrst" - "navLast" - "navNext" - "navPrev" - "mrgLeft" - "mrgRght" - "mrgRtoL" - "mrgLtoR" { # Pass the EXISTING bindScript TO the NEW keystroke defn # (ALL global shortcuts APPLY to the 'toplevel' widgets) if {[catch "bind . $tmpopts($key) {[bind . $opts($key)]}" E]} { popmsg "Bind failed: Preference '$key':\n$E\nBind Ignored" \ $w(prefs) bind . $tmpopts($key) {} ;# Failed- need to remove try? set tmpopts($key) $opts($key) ;# RETAIN old keystroke!! set feedback red } { # Success! Push to the other toplevel, & erase old hotkey # N.B> problematic if reassigning SAME hotkey TWICE (seq?) Dbg "$key binding swapped: $opts($key) to $tmpopts($key)" bind $w(merge) $tmpopts($key) "[bind $w(merge) $opts($key)]" bind .merge $opts($key) {} bind . $opts($key) {} # Also update any MENUs that are advertising the hotkey! if {[info exists w(Accel,$key)]} { foreach {mnu idx} $w(Accel,$key) { $mnu entryconfigure $idx -accelerator "$opts($key)" } } } } "mapchg" - "mapdel" - "mapins" - "mapolp" {set remap 1} "chgtag" - "currtag" - "deltag" - "difftag" - "inlinetag" - "instag" - "overlaptag" - "tagtext" - "textopt" {set remark 1} } } set opts($key) $tmpopts($key) lappend ONCE $key } # interpret this binary toggle into its true value set opts(relief) [expr {$opts(fancyButtons) ? "flat" : "raised"}] # Need to TRANSLITERATE the USER input form of "Text tags" that deal with # the display attrs of Text, LineNumbers and/or ChangeBars, and INSTEAD # compute a derivation into data lists [g(scrInf,tags) and g(scrInf,cfg)] # that can emulate (via a canvas) what WAS FORMERLY implemented (TkDiff 4.2 # and earlier) as individual Text widgets. This all comes together in # 'plot-line-info' which renders the EQUIVALENT Info data format as before, # but WITHOUT the potential line-skewing introduced by TK V8.5 enhancements translit-plot-txtags $w(LeftText) ;# L/R Text attrs identical: just grab 1 # Walk down our DERIVED precedence-list flags and find out what needs doing # (which is nothing if its all being handled by forcing a whole new Diff) # N.B> if any prior ERRORS occurred then THOSE ITEMS reverted to UNCHANGED, # and are UNABLE to trigger any derivative changes, thus do NOT restrict # performing such actions (may as well do what we KNOW needs doing) if {$redoDiff == ""} { # (what about any altered tag SETTINGs ?) if {$remark} { eval $inlActn ;# MAYBE recompute inlines (so they CAN be tagged ?) remark-diffs show-status "" # (or how about ONLY an altered inline algorithm or on/off state ?) } elseif {"$inlActn" != ""} { eval $inlActn 1 ;# recompute the inlines, but tag ONLY them } # chgd map colors if {$remap > 0 && $g(startPhase) > 1} { map-draw } } # Align, (show or hide) various data (Lnums, Cbars, etc.), and we are done cfg-toolbar do-show-Info do-show-map do-show-lineview ########################################################################### ### OK - thats it for getting preferences in place - - - ###### # BUT we MAY need to look at HOW LARGE the tool window could become # IF we follow ONLY the prefs. We wish to PREVENT the INITIAL tool window # from EXCEEDING the screensize by TREATING the 'geometry' pref more as a # 'upper-bound' than as an explicit requirement. # # IN ADDITION, despite having earlier connected the Left wdg FOR gridding, # ALWAYS *dis-connect* it from its Toplevel AGAIN after the prefs setup # REGARDLESS because its technically WRONG (only works for 1 widget -- # WE have TWO)!! Nevertheless, we need to USE it to PRESEVE any potential # RESIZE the user MAY have performed in the interim. lassign [concat [wm grid .] $prevgrid] \ GW(1) GH(1) GcW(1) GcH(1) GW(0) GH(0) GcW(0) GcH(0) Dbg "PROPOSED wm grid is WxH($GW(1)x$GH(1)) of WxH($GcW(1)x$GcH(1))pxls\n\ \twhile PREVsz was WxH($GW(0)x$GH(0)) ($GcW(0)x$GcH(0))" if {$WdG == {}} { # ON STARTUP--- (one time per session only) # Turn the SCREEN pixel size into an equiv number of Fontbased grids, # divided by 2 (for each TxtWdg), and (ugh) FUDGE its companions sizes. # (Apologies for the 'magic "-18"' in this equation - how it came to # BE is lost to history - my best guess is it represents *A* means # of accounting for what USED to be multiple vertical widgets w/fixed # widths, that '-setgrid' is NOT measuring, but ARE a portion of what # gridded-resizing is expected to manage (expressed in grid-incr(s).) # Ultimately 'maxw' is the LARGEST #of chars (ie. grid cells), that if # configured to BOTH Txtwdgs, results in NO screen-clip of the WINDOW # Similarly 'maxh' is the equivalent height value, again in grid units set maxw [expr {(([winfo vrootwidth .] / $GcW(1)) / 2) - 18}] set maxh [expr {([winfo vrootheight .] - ($opts(showlineview) ? [winfo reqheight $w(BottomText)] : 0) - [winfo reqheight $w(menubar)] - [winfo reqheight $w(toolbar)] - [winfo reqheight $w(status)]) / $GcH(1)}] # N.B> 1st-time execution @create-time: make sure REQSTD geometry # ISNT itself causing the INITIAL window to EXCEED the screen size! # User can always MANUALLY resize LATER if they so choose. scan $opts(geometry) "%dx%d" width height set GW(1) [min $maxw $width] set GH(1) [min $maxh $height] Dbg "Trim BOTH L/R to NEW computed width($GW(1)) - and detach gridding" $w(LeftText) configure -height $GH(1) -width $GW(1) -setgrid 0 $w(RightText) configure -height $GH(1) -width $GW(1) # Double it: one for each L/R TxtWdgs and CHOOSE it for final settings # N.B> *this* is the portion that "-setgrid 1" DOESN'T understand!! incr GW(1) $GW([set i 1]) } else { # Make sure we DISCONNECT the Toplevel from the widget, but PRESERVE # any GRIDDED size the USER may have MANUALLY adjusted the window to # This gets a little hairy if the NEW prefs has CHANGED the CellSz # and MAY yet be ODDER if the window manager has alterred the window, # as it appears (on X11 anyway) to 'reserve' space for the menubar # by TRIMMING the grid width-count of cells to not invade it. # Thus recompute the Width COUNT to express the same POSITION but with # utilizing the ?NEW? Cell size Width if {$GcW(0) != $GcW(1)} { set GW(0) [expr {( $GcW(0) * $GW(0) ) / $GcW(1)}] } $w(LeftText) configure -setgrid [set i 0] set hold [$WdG cget -activebackground] ;# Let user know if it worked $WdG configure -activebackground $feedback ; $WdG flash $WdG configure -activebackground $hold } update idletasks ;# update all this (we BELIEVE *up* the geom mgr chain) wm grid . $GW($i) $GH($i) $GcW(1) $GcH(1) ;# Make grid deal w/L&R wdgs Dbg " NEW wm grid is ($GW($i) X $GH($i)) ($GcW(1) x $GcH(1))" # Force a whole new Diff if user changed ANY of the result semantics # PROVIDED we passed thru re-configuration unscathed; OTHERWISE ... # remember we NEED to, but ONLY GENTLY remind User to fix their mistakes if {$redoDiff != ""} { if {$feedback == "green"} {reCalcD $redoDiff} else { popmsg "Due to previous errors, a detected need for re-invoking\ Diff has been deferred.\n\n Respecify any items that were\ 'Reverted' and 'Apply' them again" warning $w(prefs) \ "Diff request deferral..." set g(redoDiff) $redoDiff ;# Remember this as PENDING!! } } } ############################################################################### # Save customization changes. ############################################################################### proc prefsave {wdg} { global g w pref opts rcfile if {[file exists $rcfile]} { file rename -force $rcfile "$rcfile~" } set fid [open $rcfile w] # put the tkdiff version in the file. It might be handy later puts $fid "# This file was generated by $g(name)" puts $fid "# [clock format [clock seconds]]" # NOT a preference, per se - intended for auto DEPRECATED-pref adaptation puts $fid "define prefsVrsn {$g(version)}\n" # Now, put ALL of the preferences in the file # (with one small wrinkle - CERTAIN prefs have platform dependant values) # When we encounter one of THOSE, make sure we prepend the CURRENT platform # to its key, and grab ANY EXISTING others that MAY have been stored as # 'cargo' data on readin, and WRITE THOSE BACK OUT as well! # # Otherwise its just a plain old preference and out it goes # N.B> A platform prefix WILL perturb the alpha-order key list - Ah well... foreach key [lsort [array names pref]] { regsub "\n" $pref($key) "\n# " comment puts $fid "# $comment" # Watch for any of our TRIGGER key PREFIXes: "nav", "mrg" or "gen" # Ensure it emits using the PRESENT windowing system 'extra' PREFIX; # and additionally CHECK for (and output) any POSSIBLY ASSOCIATED # "cargo" values pertaining TO that SAME basic key if {[string match "\[nmg]\[are]\[vgn][string range $key 3 end]" $key]} { foreach {wSys} "aqua win32 x11" { if {[info exists opts($wSys$key)]} { puts $fid "define $wSys$key {$opts($wSys$key)}" } } # Hint: the "current" system is always AFTER any cargo -- # (sneakily IDENTIFIES what platform WROTE the preference file) puts $fid "define $w(wSys)$key {$opts($key)}\n" } else { puts $fid "define $key {$opts($key)}\n" } } # ... and now any custom code puts $fid "# custom code" puts $fid "# put any custom code you want to be executed in the" puts $fid "# following block. This code will be automatically executed" puts $fid "# after the GUI has been set up but before the diff is " puts $fid "# performed. Use this code to customize the interface if" puts $fid "# you so desire." puts $fid "# " puts $fid "# Even though you can't (as of version 3.09) edit this " puts $fid "# code via the preferences dialog, it will be automatically" puts $fid "# saved and restored if you do a SAVE from that dialog.\n" puts $fid "# Unless you really know what you are doing, it is probably" puts $fid "# wise to leave this unmodified.\n" puts $fid "define customCode {\n[string trim $opts(customCode) \n]\n}\n" close $fid if {$::tcl_platform(platform) == "windows"} { file attribute $rcfile -hidden 1 } # Let user know SOMETHING happened set hold [$wdg cget -activebackground] $wdg configure -activebackground green $wdg flash $wdg configure -activebackground $hold } ############################################################################### # Text has scrolled, update scrollbars and synchronize windows ############################################################################### proc hscroll-sync {id args} { global g w opts # If ignore_hevent is true, we've already taken care of scrolling. # We're only interested in the first event. if {$g(ignore_hevent,$id)} { return } # Scrollbar sizes set size1 [expr {[lindex [$w(LeftText) xview] 1] - [lindex \ [$w(LeftText) xview] 0]}] set size2 [expr {[lindex [$w(RightText) xview] 1] - [lindex \ [$w(RightText) xview] 0]}] if {$opts(syncscroll) || $id == 1} { set start [lindex $args 0] if {$id != 1} { set start [expr {$start * $size2 / $size1}] } $w(LeftHSB) set $start [expr {$start + $size1}] $w(LeftText) xview moveto $start set g(ignore_hevent,1) 1 } if {$opts(syncscroll) || $id == 2} { set start [lindex $args 0] if {$id != 2} { set start [expr {$start * $size1 / $size2}] } $w(RightHSB) set $start [expr {$start + $size2}] $w(RightText) xview moveto $start set g(ignore_hevent,2) 1 } # This forces all the event handlers for the view alterations # above to trigger, and we lock out the recursive (redundant) # events using ignore_hevent. update idletasks # Restore to normal set g(ignore_hevent,1) 0 set g(ignore_hevent,2) 0 } ############################################################################### # Text has scrolled, update scrollbars and synchronize OTHER Text window ############################################################################### proc vscroll-sync {id y0 y1} { global g w opts # if syncing is disabled, we're done. This prevents a nasty # set of recursive calls if {[info exists g(disableSyncing)]} { return } # set the flag; this makes sure we only get called once set g(disableSyncing) 1 map-move-thumb $y0 $y1 # If synced scrolling is turned on, then scroll OTHER window. # Further, select nearest VISIBLE diff region (if requested), if {$opts(syncscroll)} { if {$opts(autoselect) && $g(count) > 0} { # Pick probe point as linenum in middle of window set winhalf [expr {[winfo height $w(RightText)] / 2}] set Lnum [expr {int([$w(RightText) index @1,$winhalf])}] # If its a region other than the CDR, AND its START line # IS visible at the moment, it SHOULD become the new CDR if {[set i [find-diff $Lnum ]] != $g(pos)} { set topline [$w(RightText) index @0,0] set bottomline [$w(RightText) index @0,10000] lassign $g(scrInf,[hunk-id $i]) s1 if {$s1 >= int($topline) && $s1 <= int($bottomline)} { move $i 0 0 ;# N.B> (3rd arg 0) DO NOT scroll FURTHER! } } } if {$id == 1} { $w(RightText) yview moveto $y0 } else { $w(LeftText) yview moveto $y0 } } # we apparently automatically process idle events after this # proc is called. Once that is done we'll unset our flag after idle {catch {unset g(disableSyncing)}} } ############################################################################### # Draw a miniature map of the diff regions ############################################################################### proc map-draw {} { global g w opts # There are TWO reasons we might not be able to properly draw (as yet) # 1. The TK geometry manager might not have gotten around to making # its decision about how big we are supposed to be; or # # 2. The application may not have progressed far enough to HAVE the # data to plot anything useful quite yet # # Unfortunately we can only check the TK reason now (because if we test for # the other condition (a flag) here, we impose a restriction on the # application to RAISE g(startPhase) AHEAD of making its OWN call - # even when it KNOWS the data is perfectly ready. # N.B> startPhase is used globally to NOT WASTE TIME doing TK things that # wont be correct because the application isnt quite ready yet. if {$g(mapheight) && $g(mapwidth)} { # We add some transparent stuff to make the map fill the canvas # in order to receive mouse events at the very bottom. $w(mapImg) blank $w(mapImg) put \#000 -to 0 $g(mapheight) $g(mapwidth) $g(mapheight) } else {return} # A Text widget ALWAYS contains a blank line at the end - thus # (in normal cases) it tends to LOOK like it has TWO; Yet, if # the input data LACKED a this ratio could blowup... # So protect it by providing a floor value of 1.0 set lines [max [expr {double([$w(LeftText) index end]) - 2}] 1.0] set factor [expr {$g(mapheight) / $lines}] # Paint color stripes per type of every hunk foreach hID $g(diff) { lassign $g(scrInf,$hID) S E na na C1 na na C2 set y [expr {int(($S - 1) * $factor) + $g(mapborder)}] set size [expr {round(($E - $S + 1) * $factor)}] if {$size < 1} { set size 1 } switch -- "[append C1 $C2]" { "-" { set color $opts(mapdel) } "+" { set color $opts(mapins) } "!!" { set color [expr {[info exists g(overlap$hID)] ? \ $opts(mapolp) : $opts(mapchg)}] } } $w(mapImg) put $color -to 0 $y $g(mapwidth) [expr {$y + $size}] } # replot the 'thumb' on top # implicitly handles a shift in position (if being called by map-resize) eval map-move-thumb [$w(LeftText) yview] } ############################################################################### # Resize map to fit window size ############################################################################### proc map-resize {args} { global g w opts # We need to keep its size up-to-date, starting with its height # First account for spacing items surrounding the map set g(mapborder) [$w(map) cget -borderwidth] incr g(mapborder) [$w(map) cget -highlightthickness] # This can be touchy - we are racing against the TK bkgnd task that can be # cfg'ing the vertical scrolling (which calls us - at least twice - # because of EACH of the Left/Right scrollbars) # HOWEVER -- these FIRST call(s) might have PRECEDEd the geometry # manager stretching w(map) to its proper size causing it to still be # AT its 1x1 initial size which would then FAIL as we try to compute the # INTERIOR size we can plot within! # # THUS - simply watch the current map size until its viably LARGE enough # Reduce the effective height by any frame border elements (top AND bottom) # And, when that height is not stupidly short, record both width & height if {[set height [expr {[winfo height $w(map)]-($g(mapborder) *2)}]] > 10} { set g(mapheight) $height set g(mapwidth) [winfo width $w(map)] } # When we are in startPhase 1, we likely dont HAVE the data NEEDED to DRAW # So limit this proc to just TRACKING the size changes; it will be # explicitly drawn (from 'mark-diffs') when the data is ready if {$g(startPhase) > 1} { map-draw } } ############################################################################### # Toggle showing the line comparison window ############################################################################### proc do-show-lineview {{showLineview {}}} { global w opts if {$showLineview != {}} { set opts(showlineview) $showLineview } if {$opts(showlineview)} { # (re-)Manage BottomText, then tickle to update SOMEWHERE reasonable grid $w(BottomText) $w(RightText) mark set insert insert } else { grid remove $w(BottomText) } } ############################################################################### # Toggle showing inline comparison ############################################################################### proc do-show-inline {which {showInline {}}} { global opts # translation tbl TO mutually-disjoint option set other(showinline1) showinline2 set other(showinline2) showinline1 if {$showInline != {}} { set opts($which) $showInline } # mutually disjoint options # Turn requested option ON ? if {$opts($which)} { # Yes, but was OTHER option already ON ? if {$opts($other($which))} { # Yes - so mark IT as OFF set opts($other($which)) 0 } } elseif {!$opts($other($which))} { # No, turn requested option OFF ('other' is already OFF) set which {} ;# and dont generate more } # POSSIBLY recompute but ALWAYS retag (even if only removal) compute-inlines $which true } ############################################################################### # Toggle showing map or not ############################################################################### proc do-show-map {{showMap {}}} { global w opts if {$showMap != {}} { set opts(showmap) $showMap } if {$opts(showmap)} { grid $w(map) -row 1 -column 1 -stick ns } else { grid forget $w(map) } } ############################################################################### # Find and return the "diff INDEX" nearest to SCREENLINE $line. ############################################################################### proc find-diff {line} { global g # Binary search $line as either WITHIN, or PRECEEDING the index returned # N.B> $i is a REAL (0-based) list index - NOT a (1-based) Diff index; # ... UNLESS $line was BEYOND the last known hunk definition (and is thus # *THE* proper Diff index of that last hunk). if {[set i [rngeSrch diff $line "scrInf,"]] != $g(count)} { # So it all comes down to this: # If INSIDE the hunk (or it PRECEDED the FIRST hunk) - simply convert # $i to its equiv(+1) Diff index; -OR- decide which is CLOSER: # the prior ENDpt or the found STARTpt, adjusting $i to whichever WHILE # ensuring its logical conversion to its "Diff index" value set S [lindex $g(scrInf,[lindex $g(diff) $i]) 0] set E [lindex $g(scrInf,[hunk-id [max 1 $i]]) 1] if {($S <= $line) || !$i || ($S - $line < $line - $E)} { incr i } } return $i } ############################################################################### # Calculate number of lines in diff region # hID Diff hunk identifier # version (1, 2, 12, 21) left and/or right window version ############################################################################### proc diff-size {hID version} { global g lassign $g(scrInf,$hID) S E P(1) na na P(2) switch -- $version { 1 - 2 { set lines [expr {$E - $S - $P($version) + 1}] } 12 - 21 { set lines [expr {$E - $S - $P(1) + $E - $S - $P(2) + 2}] } } return $lines } ############################################################################### # Toggle showing merge preview dialog or not ############################################################################### proc do-show-merge {{showMerge ""}} { global g w if {$showMerge != ""} { set g(showmerge) $showMerge } # Re-cfg buttons to hint at state of intended Merge FILENAME (when visible) if {$g(showmerge)} { if {$g(mergefileset)} { $w(mergeWriteAndExit) configure -text "Save & Exit" $w(mergeWrite) configure -text "Save" } else { $w(mergeWriteAndExit) configure -text "Save & Exit..." $w(mergeWrite) configure -text "Save..." } if {![winfo ismapped $w(merge)]} { Dialog show $w(merge) $w(mergeText) merge-center ;# (centers the CDR - not the window) } } elseif {[winfo ismapped $w(merge)]} { Dialog dismiss $w(merge) } } ############################################################################### # Create Merge preview dialog ############################################################################### proc build-merge {} { global g w opts if {![Dialog NONMODAL $w(merge)]} { wm title [set win $w(merge)] "$g(name) Merge Preview" wm group $win . wm transient $win . wm protocol $win WM_DELETE_WINDOW {do-show-merge 0} frame $win.bottom frame $win.top -bd 1 -relief sunken # Certain widgets will need external handles, remainder are local set w(mergeInfo) $win.top.info set w(mergeText) $win.top.text set w(mergeHSB) $win.top.hsb set w(mergeWrite) $win.bottom.mergeWrite set w(mergeWriteAndExit) $win.bottom.mergeWriteAndExit # Window and scrollbars scrollbar $w(mergeHSB) -orient horizont -com [list $w(mergeText) xview] text $w(mergeText) -bd 0 -takefocus 1 \ -xscrollcommand [list $w(mergeHSB) set] canvas $w(mergeInfo) -highlightthickness 0 pack $win.bottom -side bottom -fill x pack $win.top -side top -fill both -expand yes -ipadx 5 -ipady 10 grid $w(mergeInfo) -row 0 -column 0 -sticky nsew grid $w(mergeText) -row 0 -column 1 -sticky nsew grid $w(mergeHSB) -row 1 -column 0 -sticky ew -columnspan 2 grid rowconfigure $win.top 0 -weight 1 grid rowconfigure $win.top 1 -weight 0 grid columnconfigure $win.top {0 2} -weight 0 grid columnconfigure $win.top 1 -weight 1 # buttons button $win.bottom.mRecenter -width 8 -text "ReCenter" -underline 0 \ -command merge-center button $win.bottom.mDismiss -width 8 -text "Dismiss" -underline 0 \ -command "do-show-merge 0" button $win.bottom.mExit -width 8 -text "Exit $g(name)" -underline 0 \ -command {do-exit} # These last two buttons NAMES are later re-cfg'd with "..." appended # when g(mergefileset)==0 to signify a file browser popup will occur # (provided the merge window itself is actually visible) button $w(mergeWrite) -width 8 -text "Save" -underline 0 \ -command {merge-write-file} button $w(mergeWriteAndExit) -width 8 -text "Save & Exit" -underline 8 \ -command {merge-write-file 1 } pack $win.bottom.mDismiss -side right -pady 5 -padx 10 pack $win.bottom.mRecenter -side right -pady 5 -padx 1 pack $w(mergeWrite) -side right -pady 5 -padx 1 -ipadx 1 pack $w(mergeWriteAndExit) -side right -pady 5 -padx 1 -ipadx 1 pack $win.bottom.mExit -side right -pady 5 -padx 1 # Insert tag defs (in precedence order) # N.B> This matters to 'plot-merge-info': # we NEED 'diffR' or 'diffL' as lowest precedence TAGS # (whichever applies to the diff line in question). # Its an encoding trick noting which SIDE contrib'ed a diff line. $w(mergeText) configure {*}$opts(textopt) $w(mergeText) tag configure {diffL} {*}$opts(difftag) $w(mergeText) tag configure {diffR} {*}$opts(difftag) $w(mergeText) tag configure {currtag} {*}$opts(currtag) $w(mergeText) tag raise sel ;# Keep this on top # adjust the tabstops set cwidth [font measure [$w(mergeText) cget -font] "m"] set tabstops [expr {$cwidth * $opts(tabstops)}] $w(mergeText) configure -tabs $tabstops # Lastly, this text window ALSO needs to be READONLY, so we WRAP it rename $w(mergeText) $w(mergeText)_ proc $w(mergeText) {cmd args} $::textROfcn } # N.B> cfg'ing and 'show'ing the dialog is up to 'do-show-merge' } ############################################################################### # Write merge preview to file (after optionally confirming filename) ############################################################################### proc merge-write-file {{andExit 0}} { global g w opts Dbg "-> ([expr {$g(mergefileset) ? "into" : "confirming" }] $g(mergefile))" if {!$g(mergefileset)} { # Uncertain of wanting 'nativename' .vs. 'normalize' here... # (each supposedly yields an absolute name) set path [file nativename $g(mergefile)] # Regardless, next SPLIT that into dir & file, and pass as PIECES ... # otherwise any/all user "directory browsing" will be IGNORED simply # because the '-initialfile' was passed as an absolute path!! set path [tk_getSaveFile -filetypes $opts(filetypes) \ -initialdir [file dirname $path] \ -initialfile [file tail $path] -defaultextension "" \ -parent [expr {[winfo ismap $w(merge)]? $w(merge) : $w(client)}]] if {[string length $path] > 0} { set g(mergefile) $path } else return ;# file browser cancelled out - DO NOT WRITE or EXIT } # Actually write merge output to the given filename set hndl [open "$g(mergefile)" w] set txt [$w(mergeText) get 1.0 end-1lines] puts -nonewline $hndl $txt close $hndl if {$andExit} do-exit } ############################################################################### # Add a mark where each diff begins and tag each region so they are visible. # Default case ONLY WORKS when pre-loaded text is the original (Left) version. # Optional arg allows adding/removing (ie. editting) hunk identifiers later on ############################################################################### proc merge-add-marks {{hIDS {}}} { global g w # Mark ALL lines first, so inserting choices won't mess up line numbers. # N.B> WHEN hIDS is supplied, it MUST be homogeneous: ALL or NONE can # pre-exist. And, when they dont exist, ascending order is REQUIRED. if {"$hIDS" != {}} { if {"mark[lindex $hIDS 0]" in [$w(mergeText) mark names]} { # Exists - so remove it (and every MERGE thing pertaining to it) foreach hID "$hIDS" { # CRITICAL: Put the merge text content BACK to a "Left" view ! # Then eliminate the mark AND choice (caller zaps the rest) merge-select-version $hID $g(merge$hID) 1 $w(mergeText) mark unset mark$hID unset g(merge$hID) } return } else { # NEW hID - Find WHERE to plant each new MARK # Apologies for the convoluted logic here, but we need a PRIOR # hunk location as an anchor (if there is one.) If NOT, then NO # numbers need adjusting; But if there IS, the rule of "Left only" # view DOES NOT APPLY to that FIRST anchor. Each planted MARK then # BECOMES the new anchor as we loop and is ALWAYS in "Left view" set prvHid {} foreach hID "$hIDS" { # Identify the 1st closest PRIOR hunk INDEX (if unknown) if {$prvHid == {}} { if {[set i [hunk-ndx $hID]] > 1} {incr i -1} } # If not YET known, produce prvHid and verify it really IS a # "PRIOR" hunk, setting 'i' to ITS merge-choice value if yes if {$prvHid != "" || ( "[set prvHid [hunk-id $i]]" != "$hID" \ && [set i $g(merge$prvHid)])} { # Now determine WHERE that anchor starts in 'mergeText', # ADDing its CURRENT SIZE (minus 1), plus the STARTING # position of the NEW hunk set S [expr {int([$w(mergeText) index mark$prvHid]) \ + [diff-size $prvHid $i] - 1 \ + [lindex $g(scrInf,$hID) 0]} ] # Using SCREEN numbering is OK because when we arrange # to subtract the screen END Lnum of the PRIOR hunk ... set O [lindex $g(scrInf,$prvHid) 1] # ... it will all convert to the NEW hunk location } else { lassign $g(scrInf,$hID) S na na O } # Set the NEW mark (and eventually fall thru to tagging) $w(mergeText) mark set mark$hID [incr S -$O].0 $w(mergeText) mark gravity mark$hID left set prvHid $hID ;# This becomes the NEXT anchor (as we loop) set i 1 ;# and (by defn) is ALWAYS in a "Left" view } } } else { ;# Do the entire Text (MUST BE in PURE LEFT context!!) foreach hID [set hIDS $g(diff)] { lassign $g(scrInf,$hID) S na na O $w(mergeText) mark set mark$hID [incr S -$O].0 $w(mergeText) mark gravity mark$hID left } } # ... finally, select per merge CHOICES and TAG the regions for each set currdiff [hunk-id $g(pos)] foreach hID $hIDS { # Tag and/or Insert designated Left or Right window text versions # N.B.: works PROVIDED the merge hID range is IN a "Left copy" state if {$g(merge$hID) == 1} { # (But dont do a Left 'a'-type hunk - it's not visible) if {![string match "*a*" "$hID"]} { add-tag $w(mergeText) diffL {} mark$hID "+[diff-size $hID 1]" } } else { merge-select-version $hID 1 $g(merge$hID) } # Also attach "currtag" if/when correct hunk encountered if {"$hID" == "$currdiff"} { add-tag $w(mergeText) currtag {} \ mark$hID "+[diff-size $hID $g(merge$hID)]" } } } ############################################################################### # Remove/Re-Add hunk content to the merge window # hID diff hunk identifier # oldversion (1, 2, 12, 21) previous merge choice # newversion (1, 2, 12, 21) new merge choice ############################################################################### proc merge-select-version {hID oldversion newversion} { global g w if {[set tot [diff-size $hID $oldversion]]} { $w(mergeText) DELETE mark$hID "mark${hID}+${tot}lines" } # Start of hunk in screen coordinates set S [lindex $g(scrInf,$hID) 0] # Get the text to insert directly from window switch -- $newversion { 1 { if {[set tot [set i [diff-size $hID 1]]]} { lappend txt [$w(LeftText) get $S.0 $S.0+${i}lines] diffL } else {return} } 2 { if {[set tot [set i [diff-size $hID 2]]]} { lappend txt [$w(RightText) get $S.0 $S.0+${i}lines] diffR } else {return} } 12 { if {[set tot [set i [diff-size $hID 1]]]} { lappend txt [$w(LeftText) get $S.0 $S.0+${i}lines] diffL } if {[set tot [diff-size $hID 2]]} { lappend txt [$w(RightText) get $S.0 $S.0+${i}lines] diffR incr tot $i } } 21 { if {[set tot [set i [diff-size $hID 2]]]} { lappend txt [$w(RightText) get $S.0 $S.0+${i}lines] diffR } if {[set i [diff-size $hID 1]]} { lappend txt [$w(LeftText) get $S.0 $S.0+${i}lines] diffL incr tot $i } } } # Normally (prior to Combine/Split) mark$hID would ALWAYS have been the # sole Left-'gravitized' Text mark (attached to the newline ending the # NON-hunk line PRECEEDING the hunk start edge) at any ONE Text position. # But since then, MULTIPLE marks (referring to optionally merge-able # abutted hunks) CAN COINCIDE, possibly only for a moment (between the # deletion and add done in this proc), thus causing them to cluster to the # front of ALL the possibilities - despite the need for SOME of those # choices to logically FOLLOW the insertion being made (to maintain linear # order). # Thus we must analyze EVERY insertion for such clustering and POSSIBLY # adjust the gravities of SOME to ensure the hunk ordering linearity # imposed by g(diff) remains intact... set pos [hunk-ndx $hID] set regravitize {} foreach {na markID na} [$w(mergeText) dump -mark mark$hID] { if {[hunk-ndx [string range $markID 4 end]] > $pos} { $w(mergeText) mark gravity $markID right lappend regravitize $markID } } # NOW insert AND tag it (txt holds PAIRS of textlines AND assoc tag) $w(mergeText) INSERT mark$hID {*}$txt if {"$hID" == "[hunk-id $g(pos)]"} { add-tag $w(mergeText) currtag {} mark$hID "+$tot" } # ... Nevertheless, we always LEAVE all gravities as 'Left' AFTER the # insertion, just so we need not guess (or ask) the next time around. foreach {markID} $regravitize { $w(mergeText) mark gravity $markID left } } ############################################################################### # Center the merge region in the merge window ############################################################################### proc merge-center {} { global g w # bail if there are no diffs if {$g(count) == 0} { return } # Size of diff in lines of text set hID [hunk-id $g(pos)] set difflines [diff-size $hID $g(merge$hID)] # Window height in percent set yview [$w(mergeText) yview] set ywindow [expr {[lindex $yview 1] - [lindex $yview 0]}] # First line of diff and total number of lines in window set firstline [$w(mergeText) index mark$hID] set totallines [$w(mergeText) index end] if {$difflines / $totallines < $ywindow} { # Diff fits in window, center it $w(mergeText) yview moveto [expr {($firstline + $difflines / 2) / \ $totallines - $ywindow / 2}] } else { # Diff too big, show top part $w(mergeText) yview moveto [expr {($firstline - 1) / $totallines}] } } ############################################################################### # Update the merge preview window with the designated (1,2,12,21) merge choice ############################################################################### proc do-merge-choice {newversion} { global g w opts set hID [hunk-id $g(pos)] merge-select-version $hID $g(merge$hID) $newversion set g(merge$hID) $newversion # Must ask user (when this is a collision) if their choice CLEARed it if {[info exists g(overlap$hID)]} { after idle [subst -nocommands { if {{yes} == [tk_messageBox -type yesno -icon question \ -title {Please Confirm} -parent $w(client) -default no \ -message "Did this choice RESOLVE the collision ?" ]} \ { unset g(overlap$hID) set-tag $hID currtag overlaptag if {$g(startPhase) > 1} { map-draw } } }] } if {$g(showmerge) && $opts(autocenter)} { merge-center } set g(toggle) $newversion } ############################################################################### # Extract the start and end lines for file1 and file2 from the diff header # passed in "line". ############################################################################### proc extract {line} { # the line darn well better be of the form , where op is # one of "a","c" or "d" (possibly in EITHER case). range will either be a # single number or two numbers separated by a comma. # is this a cool regular expression, or what? :-) regexp -nocase {([0-9]*)(,([0-9]*))?([acd])([0-9]*)(,([0-9]*))?} $line \ matchvar s1 x e1 op s2 x e2 if {[info exists s1] && [info exists s2]} { if {"$e1" == ""} { set e1 $s1 } if {"$e2" == ""} { set e2 $s2 } return [list $s1 $e1 $s2 $e2 $op] } else { fatal-error "Could not parse following output line from diff:\n$line" } } ############################################################################### # Add a tag to a region (of chars on a given line -OR- of lines themselves). ############################################################################### proc add-tag {wgt tag line start end} { global g if {"$line" eq {}} { # interpret OUR shorthand notation allowed for line tagging # (args passed are INTEGERS - convert to INDICE syntax) if {[string match \[0-9\]* "$start"]} {append start ".0"} if {[string match \[0-9\]* "$end"]} {append end ".0"} # 'end' may begin with JUST a plus/minus value # (+/-)xxx becomes "start (+/-)xxx lines" # xxx becomes "xxx +1 lines" set end [expr {[string match \[-+\]* "$end"] \ ? "$start${end}lines" : "$end+1lines"}] $wgt tag add $tag $start $end ;# the lines themselves } else { $wgt tag add $tag $line.$start $line.$end ;# chars ON $line } } ############################################################################### # Change the tag for a diff region. # 'hID' is the region hunk identifier (from the g(diff) list) # If 'oldtag' is present, first remove it from the region # If 'setpos' is non-zero, make sure the region is visible. # Returns the diff hunk identifier. ############################################################################### proc set-tag {hID newtag {oldtag ""} {setpos 0}} { global g w opts # Figure out which lines we need to address... if {![info exists g(scrInf,$hID)]} { # This may seem an ODD place for this to be but it IS correct # If the REASON we can't find the designated hID is because there is # NONE TO BE FOUND (zero diffs) its POSSIBLE we just did a newDiff, # reloading all of the Text widgets and their CONTENTS. # We needed to DELAY till here so g(startPhase) could be reset to # allow plot actions to occur. These just fire the traces to "re-plot" if {!$g(count)} { $w(LeftText) SEE 1.0 $w(RightText) SEE 1.0 if {$g(showmerge)} {$w(mergeText) SEE 1.0} } return "" } lassign $g(scrInf,$hID) S E na na cL na na cR # Remove old tag if {"$oldtag" != ""} { $w(LeftText) tag remove $oldtag $S.0 $E.0+1lines $w(RightText) tag remove $oldtag $S.0 $E.0+1lines # Of tags to remove, only "currtag" makes sense for the Merge window if {"$oldtag" == "currtag"} { catch { set lines [diff-size $hID $g(merge$hID)] $w(mergeText) tag remove $oldtag mark$hID "mark$hID+${lines}lines"} } } # Map chgbar marker(s) into applicable tag definition (danger: cL modified) switch -- [append cL $cR] { "-" { set coltag deltag } "+" { set coltag instag } "!!" { set coltag [expr {[info exists g(overlap$hID)] ? \ "overlaptag" : "chgtag" }] } } # Add new tag if {$opts(tagtext)} { add-tag $w(LeftText) $newtag {} $S $E add-tag $w(RightText) $newtag {} $S $E add-tag $w(RightText) $coltag {} $S $E } if {[set full [diff-size $hID $g(merge$hID)]]} { # Merge must map 'difftag' into SIDE-SPECIFIC equivalent tags if {"$newtag" == "difftag"} { # We'll use meta-programming to unwind and map the encoding # so create the transforms we need to access the pieces set sideTag([set side2(21) [set side1(12) 1]]) "diffL" set sideTag([set side2(12) [set side1(21) 2]]) "diffR" if {$g(merge$hID) < 10} { # Its a single side and occupies the 'full' length ... lappend tags $sideTag($g(merge$hID)) mark$hID $full } else { # ... or its 2 sides that SUMS to the full length (beware of 0) if {[set first [diff-size $hID $side1($g(merge$hID))]]} { lappend tags $sideTag($side1($g(merge$hID))) mark$hID $first } else { lappend tags $sideTag($side2($g(merge$hID))) mark$hID $first } # Append the 2nd piece (if needed) if {$first && $first != $full} { lappend tags $sideTag($side2($g(merge$hID))) \ mark$hID+${first}lines [expr {$full - $first}] } } } else {lappend tags $newtag mark$hID $full} foreach {tag where lines} "$tags" { add-tag $w(mergeText) $tag {} $where "+$lines" } } # Move the view on both text widgets so that the new region is visible. if {$setpos} { if {$opts(autocenter)} { center } else { $w(LeftText) SEE $S.0 $w(RightText) SEE $S.0 $w(LeftText) mark set insert $S.0 $w(RightText) mark set insert $S.0 if {$g(showmerge)} { $w(mergeText) SEE mark$hID } } } return $hID } ############################################################################### # moves to the diff nearest the insertion cursor or the mouse click, # depending on $mode (which should be either "xy" or "mark") ############################################################################### proc moveNearest {window mode args} { switch -- $mode { "xy" { set x [lindex $args 0] set y [lindex $args 1] set index [$window index @$x,$y] } "mark" { set index [$window index [lindex $args 0]] } } move [find-diff [expr {int($index)}]] 0 1 } ############################################################################### # this is called to decode a combobox entry into which hunk to jump to ############################################################################### proc moveTo {window value} { global g w # we know that the value is prefixed by the number/index of # the diff the user wants. So, just grab that out of the string regexp {([0-9]+) *:} $value matchVar index move $index 0 1 } ############################################################################### # this is called when the user scrolls the map thumb interactively. ############################################################################### proc map-seek {y} { global g w set yview [expr {(double($y) / double($g(mapheight)))}] # Show text corresponding to map; $g(activeWindow) yview moveto $yview } ############################################################################### # Move the "current" diff indicator (i.e. go to a different diff region: # If "relative" is 0 go to the GIVEN diff number; else treat as increment (+/-) # Also accepts keywords "first" and "last" ############################################################################### proc move {value {relative 1} {setpos 1}} { global g w if {$value == "first"} { set value 1 set relative 0 } if {$value == "last"} { set value $g(count) set relative 0 } # Remove old 'curr' tag set-tag [hunk-id $g(pos)] difftag currtag # Bump 'pos' (one way or the other). if {$relative} { set g(pos) [expr {$g(pos) + $value}] } else { set g(pos) $value } # Range check 'pos'. set g(pos) [max $g(pos) 1] set g(pos) [min $g(pos) $g(count)] # Set new 'curr' tag set g(currdiff) [set-tag [hunk-id $g(pos)] currtag "" $setpos] # update the buttons, etc. update-display } ############################################################################### # Align the availability of UI elements to the tools CURRENT context conditions ############################################################################### proc update-display {} { global g w opts finfo #Dbg " startPhase $g(startPhase)" if {!$g(startPhase)} return # The coding approach here is somewhat unusual: # It's organized as sequential LAYERS of decisions instead of a single # TREE of chained tests to arrive at each items proper '-state' setting. # # To limit "flickering" of widgets, that choice of LAYER is critical. # # Its best to try avoiding toggling the same widget from multiple layers, # particularly as "else" clauses, only to nearly ALWAYS redo it at a # LOWER layer. Think about the frequency that each layer-test is most # likely to branch during general operation of the tool. # # This works (and results in fewer code lines) - but its confusing to # assess WHERE (which layer) any given widget BELONGS at and if it # NEEDS to be repeated at MULTIPLE levels ##### First layer - Does the tool have enough input to attempt a diff ? if {$g(startPhase) < 2} { # disable darn near everything foreach b [list rediff ignCDR splitCDR cmbinCDR find \ prevCDR firstCDR nextCDR lastCDR ctrCDR \ mrgC1 mrgC2 mrgC12 mrgC21] { $w(${b}_im) configure -state disabled $w(${b}_tx) configure -state disabled } foreach menu [list $w(popupMenu) $w(viewMenu)] { $menu entryconfigure "Previous*" -state disabled $menu entryconfigure "First*" -state disabled $menu entryconfigure "Next*" -state disabled $menu entryconfigure "Last*" -state disabled $menu entryconfigure "Center*" -state disabled } $w(popupMenu) entryconfigure "Find..." -state disabled $w(popupMenu) entryconfigure "Find Nearest*" -state disabled $w(popupMenu) entryconfigure "Edit*" -state disabled $w(editMenu) entryconfigure "Find*" -state disabled $w(editMenu) entryconfigure "Edit File 1" -state disabled $w(editMenu) entryconfigure "Edit File 2" -state disabled $w(fileMenu) entryconfigure "File List" -state disabled $w(fileMenu) entryconfigure "Write*" -state disabled $w(fileMenu) entryconfigure "Recompute*" -state disabled $w(mergeMenu) entryconfigure "Show*" -state disabled $w(mergeMenu) entryconfigure "Write*" -state disabled -label \ [expr {$g(mergefileset) ? "Write Merge File" : "Write Merge File..."}] $w(markMenu) entryconfigure "Bookm*" -state disabled $w(markMenu) entryconfigure "Clear*" -state disabled } else { # these are generally enabled, assuming we have (or about to re-) # run a proper DIFF of a couple of files foreach b [list rediff find prevCDR firstCDR nextCDR lastCDR \ ctrCDR mrgC1 mrgC2 mrgC12 mrgC21] { $w(${b}_im) configure -state normal $w(${b}_tx) configure -state normal } $w(popupMenu) entryconfigure "Find..." -state normal $w(popupMenu) entryconfigure "Find Nearest*" -state normal $w(popupMenu) entryconfigure "Edit*" -state normal $w(editMenu) entryconfigure "Find*" -state normal $w(editMenu) entryconfigure "Edit File 1" -state normal $w(editMenu) entryconfigure "Edit File 2" -state normal if {$finfo(fPairs) > 1} { $w(fileMenu) entryconfigure "File List" -state normal } else { $w(fileMenu) entryconfigure "File List" -state disabled } $w(fileMenu) entryconfigure "Write*" -state normal $w(fileMenu) entryconfigure "Recompute*" -state normal $w(mergeMenu) entryconfigure "Show*" -state normal $w(mergeMenu) entryconfigure "Write*" -state normal -label \ [expr {$g(mergefileset) ? "Write Merge File" : "Write Merge File..."}] # Hmmm.... on my Mac the combobox flashes if we don't add this # check. Is this a bug in AquaTk, or in my combobox... :-| if {[$w(combo) cget -state] != "normal"} { $w(combo) configure -state normal } } # update the status line AND if any RE-match data exists set g(statusCurrent) "$g(pos) of $g(count)" set g(statusInfo) "" $w(viewMenu) entryconfigure "Ignore RE*" -state \ [expr {[llength $opts(ignoreRegexLnopt)] ? "normal":"disabled"}] ##### Second layer - Do any diffs exist ? # # Update the combobox, merge choices, and hunk centering. if {$g(count)} { # update the combobox. We don't want its command to fire, so # we'll disable it temporarily $w(combo) configure -commandstate "disabled" set i [expr {$g(pos) - 1}] $w(combo) configure -value [lindex [$w(combo) list get 0 end] $i] $w(combo) selection clear $w(combo) configure -commandstate "normal" # Merge choices and hunk centering foreach buttonpref {im tx} { $w(ignCDR_$buttonpref) configure -state normal $w(ctrCDR_$buttonpref) configure -state normal $w(mrgC1_$buttonpref) configure -state normal $w(mrgC2_$buttonpref) configure -state normal $w(mrgC12_$buttonpref) configure -state normal $w(mrgC21_$buttonpref) configure -state normal } $w(mrgLbl) configure -state normal $w(popupMenu) entryconfigure "Center*" -state normal $w(viewMenu) entryconfigure "Center*" -state normal $w(editMenu) entryconfigure "Ignore*" -state normal } else { # Note: this is essentially for the "No-Diffs-found" case # and effectively suggests that Layer 4 will do NOTHING! foreach b [list ignCDR splitCDR cmbinCDR ctrCDR bkmRls \ bkmSet mrgC1 mrgC2 mrgC12 mrgC21] { $w(${b}_im) configure -state disabled $w(${b}_tx) configure -state disabled } $w(mrgLbl) configure -state disabled $w(popupMenu) entryconfigure "Center*" -state disabled $w(viewMenu) entryconfigure "Center*" -state disabled $w(editMenu) entryconfigure "Ignore*" -state disabled $w(editMenu) entryconfigure "Split*" -state disabled $w(editMenu) entryconfigure "Combine*" -state disabled $w(markMenu) entryconfigure "Bookm*" -state disabled $w(markMenu) entryconfigure "Clear*" -state disabled } ##### Third layer - is CDR at (or beyond) edges of its valid range ? # (N.B> also applies to the legitimate "No Diffs Found" situation) # # Update navigation items if {$g(pos) <= 1} { foreach buttonpref {im tx} { $w(prevCDR_$buttonpref) configure -state disabled $w(firstCDR_$buttonpref) configure -state disabled } $w(popupMenu) entryconfigure "Previous*" -state disabled $w(popupMenu) entryconfigure "First*" -state disabled $w(viewMenu) entryconfigure "Previous*" -state disabled $w(viewMenu) entryconfigure "First*" -state disabled } else { ;# can transition lower foreach buttonpref {im tx} { $w(prevCDR_$buttonpref) configure -state normal $w(firstCDR_$buttonpref) configure -state normal } $w(popupMenu) entryconfigure "Previous*" -state normal $w(popupMenu) entryconfigure "First*" -state normal $w(viewMenu) entryconfigure "Previous*" -state normal $w(viewMenu) entryconfigure "First*" -state normal } if {$g(pos) >= $g(count)} { foreach buttonpref {im tx} { $w(nextCDR_$buttonpref) configure -state disabled $w(lastCDR_$buttonpref) configure -state disabled } $w(popupMenu) entryconfigure "Next*" -state disabled $w(popupMenu) entryconfigure "Last*" -state disabled $w(viewMenu) entryconfigure "Next*" -state disabled $w(viewMenu) entryconfigure "Last*" -state disabled } else { ;# can transition higher foreach buttonpref {im tx} { $w(nextCDR_$buttonpref) configure -state normal $w(lastCDR_$buttonpref) configure -state normal } $w(popupMenu) entryconfigure "Next*" -state normal $w(popupMenu) entryconfigure "Last*" -state normal $w(viewMenu) entryconfigure "Next*" -state normal $w(viewMenu) entryconfigure "Last*" -state normal } ##### Fourth layer - is the specific CDR encumbered in some way # (thus g(pos) MUST have a legitimate value) # # Update availability of bookmarking and Split/Combine actions # AND the specific merge-choice selected if {$g(count) > 0} { # Show which merge option is current for this CDR set g(toggle) $g(merge[set hID [hunk-id $g(pos)]]) # Bookmark (S)et and (C)lear items depend on the CDR marker # existance and are ALWAYS in opposite states to each other if {[winfo exists $w(bkmSF).mark$hID]} \ { set tmp {C S} } { set tmp {S C} } lassign {normal disabled} {*}$tmp foreach buttonpref {im tx} { $w(bkmRls_$buttonpref) configure -state $C $w(bkmSet_$buttonpref) configure -state $S } $w(markMenu) entryconfigure "Clear*" -state $C $w(markMenu) entryconfigure "Bookm*" -state $S # (S)plit/(C)ombine each have specific condition checks set S [expr {[splcmb-chk split $g(pos)] ? "normal" : "disabled"}] set C [expr {[splcmb-chk cmbin $g(pos)] ? "normal" : "disabled"}] foreach buttonpref {im tx} { $w(splitCDR_$buttonpref) configure -state $S $w(cmbinCDR_$buttonpref) configure -state $C } $w(editMenu) entryconfigure "Split*" -state $S $w(editMenu) entryconfigure "Combine*" -state $C } } ############################################################################### # Center entire CDR (or top line if cant fit) in each window. ############################################################################### proc center {} { global g w if {! [info exists g(scrInf,[hunk-id $g(pos)])]} {return} lassign $g(scrInf,[hunk-id $g(pos)]) S E # Window requested height in pixels set opix [winfo reqheight $w(LeftText)] # Window requested lines set olin [$w(LeftText) cget -height] # Current window height in pixels set npix [winfo height $w(LeftText)] # Visible lines set winlines [expr {$npix * $olin / $opix}] # Lines in diff set diffsize [expr {$E - $S + 1}] if {$diffsize < $winlines} { set h [expr {($winlines - $diffsize) / 2}] } else { set h 2 } # (?) TK says "...yview $number" is obsolete (but supported), # yet "... see $number" wont guarantee a SPECIFIC position $w(LeftText) mark set insert $S.0 $w(RightText) mark set insert $S.0 $w(LeftText) yview [max 0 [expr {$S - $h}]] $w(RightText) yview [max 0 [expr {$S - $h}]] if {$g(showmerge)} { merge-center } } ############################################################################### # Change the state on all of the diff-sensitive buttons. ############################################################################### proc buttons {{newstate "normal"}} { global w $w(combo) configure -state $newstate foreach buttonpref {im tx} { $w(prevCDR_$buttonpref) configure -state $newstate $w(nextCDR_$buttonpref) configure -state $newstate $w(firstCDR_$buttonpref) configure -state $newstate $w(lastCDR_$buttonpref) configure -state $newstate $w(ctrCDR_$buttonpref) configure -state $newstate } } ############################################################################### # Wipe the slate clean... ############################################################################### proc wipe {} { global g # Short cicuit useless traces and key indexing lists if {$g(startPhase)} {set g(startPhase) 1} set g(pos) 0 set g(COUNT) [set g(count) 0] set g(DIFF) [set g(diff) ""] set g(d3Left) [set g(d3Right) {}] set g(currdiff) "" # N.B: It is critical that hID-related datums, particularly those that use # their EXISTANCE as the basis for internal decision making, be REMOVED # when attempting to "start over" to avoid seemingly random errors. # NOTE: finfo is managed specifically by 'assemble-args' array unset g {scrInf,[0-9]*} array unset g {overlap[0-9]*} array unset g {merge[0-9]*} array unset g {inline,*} } ############################################################################### # Wipe all data and all windows ############################################################################### proc wipe-window {} { global g w wipe # Deleting contents also 'removes' all tags (w/o 'deleting' the defns). foreach wdg {LeftText RightText mergeText} { $w($wdg) DELETE 1.0 end eval $w($wdg) mark unset [$w($wdg) mark names] } # No one uses this - what was it for? should we just Whack it? \ if {[string length $g(destroy)] > 0} { \ eval $g(destroy) \ set g(destroy) "" \ } $w(combo) list delete 0 end buttons disabled bkmark eraseall } ############################################################################### # Search an ascending sorted list of lower/upper bound pairs for a given value. # [**> LIST MUST EXIST AS A NAMED ARRAY ELEMENT OF THE GLOBAL ('g') SPACE <**] # # Returns the index that either CONTAINS it, or FOLLOWS it; -OR- # the original list LENGTH (i.e. an invalid index), indicating 'Exceeds range' # # N.B> as long as the bounds info is in the 1st two elements of the item # being searched, additional fields may be stored in the same 'record'. ############################################################################### proc rngeSrch {rnge val {indirect {}}} { global g # Until TcL V8.(6?).? arrives, there is NO "lsearch -bisect -command" # (so this code is our own customized 'tuple binary-search' instead) # If 'rnge' contains (what amounts to) array INDICES to yet ANOTHER # table of values, then 'indirect' can be used to specify the PREFIX # name of where to indirectly access those ACTUAL range values if {$indirect != {}} { set ithItem {$g($indirect[lindex $g($rnge) $i])} } {set ithItem {[lindex $g($rnge) $i]} } # Dont bother if 'rnge' is empty or 'val' exceeds its largest value set max [llength $g($rnge)] if {([set HI [set i [incr max -1]]] >= [set LO 0]) \ && ($val <= [lindex [subst $ithItem] 1])} { # Pick the FIRST midpoint and extract its values set i [expr {($LO + $HI)/2}] lassign [lindex [subst $ithItem]] low hgh # Repetitively narrow the boundaries until we find it # N.B> (extra expression ENSURES boundary ALWAYS moves) while {$HI > $LO} { if {$val > $hgh} {set LO [expr {$LO==$i ? $i+1 : $i}]} { if {$val < $low} {set HI [expr {$HI==$i ? $i-1 : $i}]} { break}} ;# Wow - a lucky HIT - stop NOW!! # Pick NEW midpoint and try again set i [expr {($LO + $HI)/2}] lassign [lindex [subst $ithItem]] low hgh } } else {return [incr max]} return $i } ############################################################################### # Specialized range-check machinery to find ancestor collisions (by mark-diffs) # Return an encoded 'category' of Ancestor mark(s) found in the requested range # Categories are: 0 -> None # 1 -> Additive # 2 -> Deletive # 3 -> Both # # N.B> optional arg is an initially unknown VarName (in callers stackframe) # to permit CHAINED accesses. It avoids searching for the correct 'anc' range # as is done on the FIRST such access by storing its LAST USED 'anc' index # to simply resume from that point (not unlike a co-routine or iterator) ############################################################################### proc chk-ancRnge {anclst S E {prev {}}} { global g if {![set result [llength $g($anclst)]]} {return 0} if {$prev != {}} {upvar $prev ndx} ;# (Remember where NEXT call starts) # Do we skip 'binary searching' for the first ancestor range? if {![info exists ndx]} { # No...but if searching yields 'Exceeds known ranges' THATs an answer, # yet needs DECREMENTing (to a valid value) to be CACHEd (if it will) if {$result == [set ndx [rngeSrch $anclst $S]]} {incr ndx -1} } # Get values of first ancestor range to check # (args S & E are expected to BE in min/max order) lassign "$S $E 0 [lindex $g($anclst) $ndx]" s(0) e(0) result s(1) e(1) mrk # Check ancestral ranges until found (or is known it CANT be found) while {$s(1) <= $e(0)} { # choose i'th segment as leftmost (and j as other - i.e. 0/1) set j [expr {[set i [expr {$s(0) > $s(1)}]] == 0}] # Look for range intersections and record category if {$s(0) == $s(1) || $e($i) >= $s($j)} { set result [expr { $result | ([string is lower $mrk] ? 1 : 2)}] } # Step to next ancestor range (if one actually exists) if {$ndx < [llength $g($anclst)] - 1} { lassign [lindex $g($anclst) [incr ndx]] s(1) e(1) mrk } else {break} } # If result is true, then $s($j) and [min $e($i) $e($j)] # IS the OVERLAP BOUNDS (I think) # (could maybe be returned as an optional upvar'ed "list" ?) return $result } ############################################################################### # Interactively cause the CDR to be treated as suppressed ############################################################################### proc ignore-hunk {} { global g w # Ensure g(pos) will remain within the eventual g(diff) if {[set i $g(pos)] == [llength $g(diff)]} {incr i -1} # Then re-categorize the current hunk set hID $g(currdiff) if {[mark-diffs [list $hID [string map {a A c C d D} $hID]]]} { move $i 0 1 buttons normal } else { $w(combo) configure -commandstate disabled $w(combo) configure -value {} $w(combo) configure -commandstate normal after idle {show-status "Files now APPEAR as identical"} buttons disabled } } ############################################################################### # Mark difference regions and build up the combobox # N.B> Be very AWARE of when/why g(diff) .vs. g(DIFF) is used!!! ############################################################################### proc mark-diffs {{rmvrpl {}}} { global g w opts set wdg(1) $w(LeftText) set wdg(2) $w(RightText) set g(COUNT) [set g(count) [set boxW [set delta(1) [set delta(2) 0]]]] # Distinguishing between EDITTING .vs. LOADING of the global diff hunk # list is defined by the OPTIONAL "(r)e(m)o(v)e and (r)e(pl)ace" argument if {$rmvrpl != {}} { set Lpad [set Rpad {}] ;# (tmps for scheduling Pad-line removal) set hack {} ;# Dont need the responsiveness hack ... set g(startPhase) 1 ;# ... but RE-suspend "plot-line-info" $w(combo) list delete 0 end ;# ComboBox will simply be RE-loaded # Next do the REMOVEs of hunks from the diff list FIRST (including all # that depends on them) ... REPLACing with the NEW hunks before return. # This mostly works because the entries being removed occupy the # SAME SINGLE contiguous run as the entries taking their place. # Happily, Tcl ALLOWS modifying a list ACTIVELY being processed (due # to its incessant CLONING of things DURING their modification)!! # # N.B> We DO NOT re-evaluate "suppression" rules when editting diffs! # It would interfere with the ability to RE-edit later...sorry! set i 0 foreach d $g(diff) { if {[set ndx [lsearch -exact $rmvrpl $d]] >= 0} { if {![info exists inject]} { set i [set inject [lsearch -exact $g(diff) $d]];#1st delete } # Only ONE side ever has Pad lines - remove them lassign $g(scrInf,$d) na E Pl na na Pr set S [incr E] ;# (shift range downward for Widget addressing) if {$Pl} {lappend Lpad [incr S -$Pl].0 $E.0} ;# Left Padding if {$Pr} {lappend Rpad [incr S -$Pr].0 $E.0} ;# Right Padding $w(LeftText) mark unset vL$d ;# Left Vertical-Linearity $w(LeftText) tag delete vL$d ;# Left Vertical-Linearity $w(RightText) mark unset vL$d ;#Right Vertical-Linearity $w(RightText) tag delete vL$d ;#Right Vertical-Linearity bkmark erase [incr i] ;# Eliminate bookmark (if any) merge-add-marks [list $d] ;# ... and its Merge data unset -nocomplain g(inline,$d) ;# inline diffs unset -nocomplain g(overlap$d) ;# 3way diff collision unset g(scrInf,$d) ;# line numbering information # Now that everything is gone, remove the hID from $rmvrpl set rmvrpl [lreplace $rmvrpl $ndx $ndx] } elseif {$i>0} { break } ;# early out once contiguous block found } # We MUST have deleted SOMETHING by now... ? if {$i} { # Must eliminate Padding all at once to avoid shifting the indices if {[llength $Lpad]} {$w(LeftText) DELETE {*}$Lpad} if {[llength $Rpad]} {$w(RightText) DELETE {*}$Rpad} # ... finally overlay the NEW hIDs ... REPLACING what was deleted # N.B> 'i' begins as an "index+1" position against g(diff) ... # afterward, 'inject' refers to 1st NEW index in g(DIFF) set j [lsearch -exact $g(DIFF) [lindex $g(diff) $inject]];#map 1st, # N.B.: $rmvrpl COULD right now be a 1 element list of an IGNORED # hunk that MUST be added to g(DIFF), but **NOT** to g(diff)!! # (as fabricated by the 'ignore CDR' user action) if {[llength $rmvrpl] !=1 || [string match {*[acd]*} {*}$rmvrpl]} { set g(diff) [lreplace $g(diff) $inject [incr i -1] {*}$rmvrpl] } { set g(diff) [lreplace $g(diff) $inject [incr i -1]]} set i [expr {$i - $inject + $j}] ;# readjust i to last mapped index set g(DIFF) [lreplace $g(DIFF) [set inject $j] $i {*}$rmvrpl] } } else { # Ain't this clever? We want to update the display as soon as we've # marked enough diffs to fill the display so the user will have the # impression we're fast. But, to prevent it from slowing us down too # much, put this code in a variable and delete it AFTER it fires once set hack { # for now, just pick a number out of thin air. Ideally # we'd compute the number of lines that are visible and # use that, but I'm too lazy today... if {$g(count) > 25} { update idletasks set hack {} ;# once fired, dont bother doing it again } } } # Compute minimal spacing to format the combobox entry numbering set fmtW [string length "[llength "$g(diff)"]"] # Walk through each diff hunk DERIVING global data for eventual use foreach d $g(DIFF) { # If its Info ALREADY exists, we are obviously in EDIT mode, needing # primarily to keep the 'delta(*)'s updated AND (re)add into comboBox if {[info exists g(scrInf,$d)]} { # Get most of what we know of this hunk ... # ... derive its type and determine if we count it as a REAL hunk lassign $g(scrInf,$d) S E Pl na Cl Pr Or Cr if {[string is lower [set type [expr {"$Cl$Cr"=="" ? "I":"i"}]]]} { incr g(count) } incr g(COUNT) ;# It ALWAYS counts in the superset list # However, ALL existing hunks BEYOND the injected entries require # certain minor realignments: # a) "scrInf,*" Ofst fields MUST be rewritten to the NEW deltas # likewise the S & E fields must adjust to the new delta SUM # b) if REAL (and bookmarked?), it will need a renumbered label if {$inject < $g(COUNT)} { set S [expr {$delta(2) - $Or + $S}] set E [expr {$delta(2) - $Or + $E}] set g(scrInf,$d) \ [list $S $E $Pl $delta(1) $Cl $Pr $delta(2) $Cr] if {"$type" == "i"} {bkmark $d $g(count)} } incr delta(1) $Pl ;# Keep the deltas CURRENT for EVERY hunk incr delta(2) $Pr } elseif { [set result [extract $d]] != ""} { # Otherwise, its a NEW hunk needing to be processed lassign $result s(1) e(1) s(2) e(2) type # Count it ... but only NON-suppressed hunks count as REAL incr g(COUNT) if {[string is lower $type]} { incr g(count) # In addition, before ALTERING any of those start/end numbers, # check for an active 3way diff and whether this hunk collides # any ancestral changes together. Moreover, also establish its # 'default' L/R merge choice (Ancestral over User preferred) if {$g(is3way)} { set g(merge$d) [set i [set j 0]]; # begin as unknown switch -- $type { "a" { set i [chk-ancRnge d3Right $s(2) $e(2) RaNDX] } "c" { set j [chk-ancRnge d3Left $s(1) $e(1) LaNDX] set i [chk-ancRnge d3Right $s(2) $e(2) RaNDX] } "d" { set j [chk-ancRnge d3Left $s(1) $e(1) LaNDX] } } # ACTUAL choice is based on a 4x4 table of possibilities # 1st row handles 'Del's ; 1st col handles 'Add's ; # and the rest applies to 'Chg's; Negative is a COLLISION # N.B> LOGICAL chances of SOME lower-right values occurring # is LOWER than the apparent overwhelming -2's suggests! if {[set g(merge$d) [lindex {{ 0 1 2 -2} { 2 -2 2 -2} { 1 1 -2 -2} {-2 -2 -2 -2}} $i $j]] < 0} { set g(overlap$d) 1; # Collision set g(merge$d) 2; # Dflt Choice is 'Right' because # its implied by the original (L/R) file arrangement } if {!$g(merge$d)} {set g(merge$d) $opts(predomMrg)} } else { set g(merge$d) $opts(predomMrg) } ;# when NO 3way at all } # Now REmap s(1),e(1) s(2),e(2) to refer to SCREEN linenumbers # First, compute the RAW Left and Right linecounts set siz(1) [expr {$e(1) - $s(1)}] set siz(2) [expr {$e(2) - $s(2)}] # Then adjust BOTH starts, accounting for ALL PRIOR hunk padding # (these then become this hunks starting SCREEN linenumbers) incr s(1) $delta(1) incr s(2) $delta(2) # Next, based on what TYPE of diff it is, decide WHICH widget: # - gets any (and how much) blankline padding (via setting "i") # - gets what type-associated ChangegBar character # N.B. Note that the RAW s($i) on "a,d"-types is 1-less initially # because it refers to a line number BEFORE the line that (by # virtue of the add/delete) does not actually exist on that side. # Uppercase types are hunks to be IGNORED (they get Padded only) set pad(1) [set pad(2) 0] set cbar(1) [set cbar(2) ""] switch -- $type { "A" - "a" { ;# an 'add' pads to the LEFT widget set pad([set i 1]) [incr siz(2)] incr s(1) ;# (RAW lnum was the one BEFORE the add) set cbar(2) [expr {$type == "a" ? "+" : ""}] } "D" - "d" { ;# a 'delete' pads to the RIGHT widget set pad([set i 2]) [incr siz(1)] incr s(2) ;# (RAW lnum was the one BEFORE the delete) set cbar(1) [expr {$type == "d" ? "-" : ""}] } "C" - "c" { ;# a 'change' pads to the SHORTER widget set i [expr {$siz(1) < $siz(2) ? 1 : 2}] set pad($i) [expr {abs([incr siz(1)] - [incr siz(2)])}] set cbar(2) [set cbar(1) [expr {$type == "c" ? "!" : ""}]] } } # Now, compute the END line numbers to THEIR screen values... incr siz($i) $pad($i) set e(2) [expr {$s(2) + $siz(2) - 1}] # IMPORTANT: if you've done the math (and logic), "e(1)" MUST EQUAL # "e(2)" when all is complete. But we still need the UNpadded value # as well -- so UNTIL THE NEXT ITERATION: # e(2) will hold the PADDED end value and # e(1) the UNpadded one. # Watch CAREFULLY where each gets used!!! # Moreover, s(1) will LIKELY be utilized as an INITIALIZED temp set e(1) [expr {$e(2) - $pad($i)}] # SAVE all this SCREEN ADJUSTED data for mapping various operations # later on throughout the tool # N.B!! s(1),e(1) == s(2),e(2) so only one set is recorded set g(scrInf,$d) [list $s(2) $e(2) \ $pad(1) $delta(1) $cbar(1) $pad(2) $delta(2) $cbar(2) ] # Accumulate any newly computed padding for the NEXT iteration incr delta($i) $pad($i) # FINALLY, we can ACTUALLY pad the widget into compliance (if reqd), # and plant the vL* MARK on that FINAL LINE of a REAL hunk...to # retain WHERE to place the vertical linearity TAG (vL*) later on, # AFTER any user pref changes (which MIGHT mention fonts). # # The vL* TAG ensures each L/R hunk pairing remains the same # PHYSICAL height in BOTH Text widgets, PROVIDING a L/R # alignment of MOST lines, diminishing the scrolling skew # introduced by TK Vrsn(>= 8.5) "display .vs. logical" lines. if {$pad($i) > 0} { $wdg($i) INSERT $e(1).end [string repeat "\n" $pad($i)] } # (of course, only REAL hunks might ever need skew compensation) if {[string is lower "$type"]} { $w(LeftText) mark set vL$d $e(2).0 $w(RightText) mark set vL$d $e(2).0 } # Lastly - (if on) generate inline diff data for this hunk if {"$type" == "c" && ($opts(showinline1) || $opts(showinline2))} { while {$s(1) <= $e(1)} { if {$opts(showinline1)} { find-inline-diff-byte $d [expr {$s(1) - $s(2)}] \ [$w(LeftText) get $s(1).0 $s(1).end] \ [$w(RightText) get $s(1).0 $s(1).end] } else { find-inline-diff-ratcliff $d [expr {$s(1) - $s(2)}] \ [$w(LeftText) get $s(1).0 $s(1).end] \ [$w(RightText) get $s(1).0 $s(1).end] } incr s(1) ;# (warned you this value could be trashed) } } } # Append entry into combobox (and hilight when its a 3way collision) if {[string is lower "$type"]} { $w(combo) list insert end \ "[set item [format "%*d: %s" $fmtW $g(count) $d]]" if {[info exists g(overlap$d)]} { $w(combo) list itemconf end -background $opts(mapolp) } # measure it, remembering the LONGEST entry seen ... set boxW [max $boxW [string length "$item"]] eval $hack ;# ... and TRY to update display ASAP } } # Beyond here, MOST other tool functions are based on g(diff) and g(count) # [big exception is "line numbering" code that uses g(DIFF) and g(COUNT)] # Shrinkwrap combobox TO its data (avoids clipping AND excess space) # (N.B> decrement of 2 ??appears?? to be an artifact of combobox font?) # (or perhaps spacing STOLEN from the width for the pulldown button?) if {$g(count)} { $w(combo) configure -width [incr boxW -2] } # Ensure that any NEWLY CREATED diff regions are 'mark'ed in the MERGE # window (so they can be tagged in the next step -- note that 'rmvrpl' here # either HAS the list of ONLY the additions, or is EMPTY which flags the # procedure to mark EVERY diff (unless it was an SINGLE suppress request) if {$g(count) && ([llength $rmvrpl]!=1 || [string match {*[acd]*} [lindex $rmvrpl 0]])} { merge-add-marks $rmvrpl } # Lastly, ensure the MAP reflects the CURRENT diffs and go (re-)TAG it all map-draw remark-diffs return $g(count) } ############################################################################### # start a new diff from the popup dialog ############################################################################### proc do-new-diff {} { global g finfo # Unlock the PRESENT mergefile settings (but leave name for now), then ... # Pop up the dialog to collect the args and form them together # into a command - bailing out if dialog cancels or args is malformed set g(mergefileset) 0 if {![newDiff] || ![assemble-args]} return set g(disableSyncing) 1 ;# turn off syncing until things settle down # make new args available then do the diff reload-multifile $finfo(fPairs) do-diff move first 1 1 update-display catch {unset g(disableSyncing)} } ############################################################################### # Remark difference regions... ############################################################################### proc remark-diffs {} { global g w pref opts if {$g(statusInfo) == ""} {show-status "Re-Marking differences..."} # Delete, then reconfigure ALL tags (based on the current options) ... foreach win [list $w(LeftText) $w(RightText) $w(mergeText)] { eval $win tag delete [$win tag names] # (tag names here abbreviated simply to fit in 80 columns) # IMPORTANT - this DEFINES tag PRECEDENCE throughout TkDiff # (and MUST SYNC with the 'translit-plot-txtags' emulation coding!!) foreach tag {diff curr del ins chg overlap inline sel} { # Yet 'difftag' cfgs into mergeText as TWO names: diffR & diffL, # but as ITSELF in the main Text windows (despite the same attrs) # - a coding trick so merge knows which SIDE provided the line! # # Catch provides an error check against bad userpref settings if { "$tag" == "sel"} { $win tag raise $tag } elseif {($win != $w(mergeText) || $tag == "curr") \ && [catch "$win tag configure ${tag}tag $opts(${tag}tag)"]} { popmsg "Invalid settings for \"$pref(${tag}tag)\": \ \n\n'$opts(${tag}tag)' is not a valid option string." # Re-run OUTSIDE the catch to let it blow up for real eval "$win tag configure ${tag}tag $opts(${tag}tag)" return } elseif {$win == $w(mergeText) && "$tag" == "diff"} { # (difftag has already been validity checked by now) $win tag configure ${tag}R {*}$opts(${tag}tag) $win tag configure ${tag}L {*}$opts(${tag}tag) } } } # Now, reapply the tags applicable to all the diff regions foreach hID $g(diff) { # First the difftag ... set-tag $hID difftag # ... then a POTENTIALLY needed UNIQUE vertical linearity tag ... # (on LAST line of every hunk - MIGHT never be configured) # N.B: uses a preset MARK to survive the earlier mass TAG deletion add-tag $w(LeftText) vL$hID {} vL$hID vL$hID add-tag $w(RightText) vL$hID {} vL$hID vL$hID # ... and finally any inline annotations if {[string match "*c*" "$hID"] && \ ($opts(showinline1) || $opts(showinline2))} { remark-inline $hID false ;# "false" -> Cfg (not ReCfg) skew # Remember to handle NON chg-type hunks for screen height skew also } else { de-skew-hunk $hID false } } # Turn "plot-line-info" processing back ON if it was OFF if {$g(startPhase) == 1} {incr g(startPhase)} # finally, re-establish the current diff set g(currdiff) [set-tag [hunk-id $g(pos)] currtag] } ############################################################################### # Update Skew correction on given hunk ############################################################################### proc de-skew-hunk {hID {reCfgSkew true}} { global g w # Get screen difftag range (same for Left or Right) lassign $g(scrInf,$hID) s1 e1 # Force measurements to be REcalculated WITHOUT any PRIOR value if {$reCfgSkew} { $w(LeftText) tag configure vL$hID -spacing3 0 $w(RightText) tag configure vL$hID -spacing3 0 } update idletasks ;# Tk8.6.3 BUG: measure AFTER things go quiet (see below) set lsz [$w(LeftText) count -update -ypixels $s1.0 $e1.0+1lines] set rsz [$w(RightText) count -update -ypixels $s1.0 $e1.0+1lines] # Only config shortest if NEEDED to make left/right screen heights agree if {$lsz < $rsz} { $w([set wdg LeftText]) tag configure vL$hID -spacing3 [expr $rsz-$lsz] } elseif {$lsz > $rsz} { $w([set wdg RightText]) tag configure vL$hID -spacing3 [expr $lsz-$rsz] } else {return} # N.B. BUT - RERUN the "count" JUST TO FORCE '-update' to be completed! # -otherwise ANY scroll performed (BEFORE 'idletasks' finishes?) is wrong # As of Tk8.6.6 a new subcmd (sync) is possible, but this method MIGHT # still be faster given it targets a smaller specific indice range. $w($wdg) count -update -ypixels $s1.0 $e1.0+1lines update idletasks ;# Tk8.6.3 *BUG*: "legacy" Txtwdg implementation MIGHT # invalidate internal BTree ptrs when the data size is very small. SEEMS to # involve deferred processing somehow, and will hopefully be gone if/when # the Txtwdg impl is redone (see http://core.tcl.tk/ TIP #466) # Both "idletasks" calls (here and earlier) has STOPPED an observed SEGV. } ############################################################################### # Add inline tags for a given SINGLE hunk to BOTH Text widgets ############################################################################### proc remark-inline {hID {reCfgSkew true}} { global g w # N.B> Oddly enough, it is legitimately POSSIBLE that ABSOLUTELY IDENTICAL # linepairs can be 'inline-diff'ed resulting in NO output list of ranges! # Distinction is ENTIRELY about how Diff chose to describe the hunk... # eg.: 1c1,2 # | abc | | abc | <--- compares identical # | | | d e | <--- skips (left is empty) # | xyz | | xyz | # versus: 1a2 # | abc | | abc | # | | | d e | (only 'c' types do inlines) # | xyz | | xyz | # # (Diff output can be quite capricious at times!!) if {[info exists g(inline,$hID)]} { set wdg(l) "LeftText" set wdg(r) "RightText" # Presumes 'inlinetag' was ALREADY removed from BOTH Text widgets set Lno [lindex $g(scrInf,$hID) 0] foreach {side lndx Scol Ecol} $g(inline,$hID) { add-tag $w($wdg($side)) inlinetag [incr lndx $Lno] $Scol $Ecol } } de-skew-hunk $hID $reCfgSkew } ############################################################################### # Post some SHORT informational text. # Behavior DEPENDS slightly on overall state (initial startup .vs. running) # where target LABEL widget should be GROWN to accomodate the info msg passed. ############################################################################### proc show-status {message} { global g w # Grow (pre-built ONLY) status widget to accept posting message if {!$g(startPhase) && [winfo exist .status] && [$w(statusLabel) cget -width] < [set grow [string length $message]]} { $w(statusLabel) config -width [min 70 $grow] } set g(statusInfo) $message update idletasks } ############################################################################### # A limited Cohen-Sutherland line CLIP Alg classifier (only does 1 dimension) # thus its name: "half clip" ; Zero return means total INCLUSION ############################################################################### proc hCLIP {s e mn mx} { return [expr ($e<$mn)*8 + ($e>$mx)*4 + ($s<$mn)*2 + ($s>$mx)] # Essentially a binary-packed PAIR of 2bit-wide values, thus has values # from 0 to 15. When in use, only roughly HALF (9) are LOGICALLY possible } ############################################################################### # Compute differences (start from the beginning, basically). ############################################################################### proc rediff {} { global g w opts finfo buttons disabled # Read the files into their respective widgets # and derive the overall line number magnitude. set g(lnumDigits) 0 set i [set j [expr {[set pairnum $finfo(fCurpair)] * 2}]] incr i -1 set Statmsg [set msg {}];# Assume this is all gonna work ... foreach {LR ndx} [list Left $i Right $j] { # When finfo(pth,X) is NOT set yet, its a SCM file that # has not yet been obtained -- go get it show-status "reading $finfo(lbl,$ndx) ..." if {![info exists finfo(pth,$ndx)]} { # if it fails: finfo(pth,$ndx) will LIKELY be an empty tmpfile if {"" != [set msg [scm-chkget $ndx]]} {popmsg "$msg"} } if {[catch {set hndl [open "$finfo(pth,$ndx)" r]}]} { fatal-error "Failed to open file: $finfo(pth,$ndx)" } else {fconfigure $hndl -translation \ [expr {"$::tcl_platform(platform)" == "windows" ? "crlf" : "lf"}]} $w(${LR}Text) REPLACE 1.0 end [read $hndl] # Must also replace the merge window contents (w/Left contents) if {$LR == "Left"} { seek $hndl 0 start ;# Rewind the Left file catch { $w(mergeText) mark unset [$w(mergeText) mark names] } $w(mergeText) REPLACE 1.0 end [read $hndl] if {![regexp {\.0$} [$w(mergeText) index "end-1lines lineend"]]} { $w(mergeText) INSERT end "\n" } } close $hndl set lines [expr {int([$w(${LR}Text) index end-1lines])}] set g(lnumDigits) [max [string length "$lines"] $g(lnumDigits)] } # Provide feedback on this filepair being successfully accessed (or not)... # Decorate all the visuals per this set of files...and then finally push # g(lnumDigits) AND is3way to reconfig width of Info widgets (do-show-Info) $w(multiFileMenu) entryconf [expr {$pairnum + 2}] \ -activebackg [expr {"$msg" != {} ? {Tomato} : {PaleGreen}}] alignDecor $pairnum do-show-Info # Diff the two files and store the summary lines into 'g(diff)' set diffcmd "$opts(diffcmd)" if {$opts(ignoreblanks)} {lappend diffcmd "$opts(ignoreblanksopt)" } lappend diffcmd $finfo(pth,$i) $finfo(pth,$j) show-status "Executing {$diffcmd}" lassign [run-command "$diffcmd"] diffOUT diffERR diffRC set g(returnValue) $diffRC ;# Record REAL RC # Now, when that exit code *IS* 0 there are NO differences; when # its a 1 there *ARE* differences (but *PERHAPS* not what you expect) # Any OTHER exit code simply means trouble if {$diffRC < 0 || $diffRC > 1 || $diffERR != ""} { popmsg "diff failed:$diffRC:\n$diffERR\n\ [string range $diffOUT 0 75] ... (partial)" # Simulate 'identical' going forward: (avoids any further issues) set Statmsg ">> NO ACTION TAKEN << due to errors" set diffOUT {} set diffRC 0 set lines {}; # Simulate 'identical' to avoid issues } elseif {"[set lines [split $diffOUT "\n"]]" != "" && $diffRC} { # Historical note: OLDER 'diff' vrsns USED to produce: # "Binary files ..(names).. are different" ON stdout WITH RC=1 # Newer ones do similar, BUT w/RC=2 (when non-text files are used) # At least CHECK 1st line LOOKS (mostly) like a 'normal' diff header if {[regexp {[0-9,]+[acd][0-9,]+} [lindex $lines 0]]} { # Close enough - (at least protects us from unexpected formats) lappend lines "0"; # Cheap trick: sentinel will flush NEXT loop } else { popmsg "diff failed:$diffRC: Unrecognized diff format: [string range $diffOUT 0 75] ... (partial)" set Statmsg ">> NO COMPARISON POSSIBLE << due to errors" set lines {}; # Again, simulate 'identical' to avoid issues set diffRC 0 } } # Collect all lines containing diff hunk headers # N.B> Critical Concept- There are TWO lists of headers: # 'g(DIFF)' is the superset and includes EVERY reported hunk # 'g(diff)' is POTENTIALLY a subset, but is USED by MOST OF THE TOOL # # The distinction comes from options the user MAY have used to suppress # certain kinds of hunks (blanklines, REmatched) which WE MUST PROCESS and # NOT pass to Diff (it would HIDE places where widget padding is needed). # Our technique is to UPPERCASE the headers for hunks being suppressed, # but then ALSO restrict such headers to the 'g(DIFF)' list. # # When the options are NOT used, both lists are identical - (but beware # of LATENT bugs being CAUSED by keying some downstream feature to the # WRONG list!!). Otherwise, THIS code simply APPLYS the suppression options # and forms BOTH lists, in a "state machine" style of parsing. Both headers # AND diff content lines must be read, as the rules for "suppression" need # EVERY line of the hunk to be QUALIFIED before ignoring is possible. # Generally, it is Text widget "Padding" and "Line numbering" tasks that # require the use of 'g(DIFF)'; everything(?) else should use 'g(diff)'. set hID [set g(DIFF) [set g(diff) {}]] foreach line $lines { switch -glob [string index $line 0] { "-" {continue} "[0-9]" {if {$opts(ignoreEmptyLn) \ || ($opts(ignoreRegexLn) && $opts(ignoreRegexLnopt) != "")} { if {[string length $hID]} { if {[string match {*[acd]*} $hID]} { lappend g(diff) $hID } lappend g(DIFF) $hID } # Presume it WILL suppress (re-activating at each hunk) set hID [string toupper $line] if {[set Esuppress $opts(ignoreEmptyLn)]} { if {$opts(ignoreblanks) \ && ([string length [string map {b {} w {} Z {}} \ $opts(ignoreblanksopt)]] \ < [string length $opts(ignoreblanksopt)])} { set Eexpn {^..[[:space:]]*$};# any of "-bwZ" used } else {set Eexpn {^..$}} ;# otherwise } set Rsuppress [llength $opts(ignoreRegexLnopt)] } elseif {[string length $line]-1} { lappend g(diff) $line lappend g(DIFF) $line set hID {} } } "[<>]" {if {![string match {*[ACD]*} $hID]} {continue} # Verify this lines data against the reasons for suppression if {$Esuppress} { if {![regexp $Eexpn $line]} {set Esuppress 0} } if {$Rsuppress} { set Rsuppress [llength $opts(ignoreRegexLnopt)] # (if ANY expn matches, then the suppression remains valid) foreach Iexpn $opts(ignoreRegexLnopt) { if {![regexp $Iexpn [string range $line 2 end]]} { incr Rsuppress -1} {break} } } # Cancel the presumption of suppression if the reason is gone if {!$Esuppress && !$Rsuppress} {set hID [string tolower $hID]} } } } Dbg "DIFF([llength $g(DIFF)]) .vs. diff([llength $g(diff)])" if {$diffRC && $g(is3way)} { # Make sure we HAVE the ancestorfile (go get it if not) if {![info exists finfo(apth,$pairnum)]} { # if it fails: finfo(apth,$pairnum) may LIKELY be an empty tmpfile, # making the Ancestrals APPEAR as 1 BIG Add (on each side) if {"" != [set msg [scm-chkget "a$pairnum"]]} {popmsg "$msg"} } set g(d3Left) [set g(d3Right) ""]; # ERASE the 2 global output lists # SO - the WHOLE IDEA here is that based on a common ancestor, lines can # ONLY be ADDed or DELeted (a CHG is some of both). ADDed lines always # SURVIVE into the target, but a DEL line 'survives' only when the OTHER # side FAILS to ALSO delete it. # # >> We want the LOCATION of EVERY survivor (per its side) << # # Thus NON intersects simply get recorded, although to WHICH SIDE # depends on its ADD/DEL status. Adds go to the side of occurence, Dels # obviously can only be marked on the OPPOSING side for those portions # that were NOT deleted from BOTH ... but COLLISIONS are tricky! ######################################### # We've kinda "folded" this processing INTO itself because the # mapping technique TRUELY requires reading BOTH Diff streams # simultaneously in a "data directed" fashion. But to conserve both # time & code, we've reorganized it to do everything as a 3 pass # hybrid state-machine, reading first one, THEN the other stream # (during which MOST of the processing will occur), with a final # 'flush' pass to finish mapping any PENDING items from the 1st pass. # # N.B: 'i','j' ARE available for tmp usage once loop starts (a Tcl-ism) # (the trailing ZERO sentinel forces the FINAL "3rd iteration" flush) foreach {NDX LR} [list $i Left $j Right 0] { if ($NDX) { # In 3-way merge - we diff EACH file "from" the ancestor set diffcmd "$opts(diffcmd)" if {$opts(ignoreblanks)} {lappend diffcmd $opts(ignoreblanksopt)} lappend diffcmd $finfo(apth,$pairnum) $finfo(pth,$NDX) show-status "Executing {$diffcmd}" lassign [run-command "$diffcmd"] diffOUT diffERR RC;#NOT diffRC if {$RC < 0 || $RC > 1 || $diffERR != ""} { popmsg "Ancestor/$LR diff failed:$RC:\n$diffERR\n\ [string range $diffOUT 0 75] ... (partial)" set diffRC 0; # Indicate we CANT do the 3way break } elseif {"[set lines [split $diffOUT "\n"]]" != "" && $RC} { if {![regexp {[0-9,]+[acd][0-9,]+} [lindex $lines 0]]} { popmsg "Ancestor/$LR diff: Improper diff format:\n\n\ [string range $diffOUT 0 75] ...\n (partial output)" set diffRC 0; # Again, we CANT do the 3way break } } elseif {!$RC} { popmsg "Ancestor/$LR diff: Inconsistent data:\n\n\ Ancestor must NOT be identical to $LR side file" set diffRC 0; # Yet again, we CANT do the 3way break } # (3rd pass? ... FAKE our way INSIDE next loop (to flush Left side) } else {set lines [list { }]} foreach line $lines { # Spin until we detect a hunk header line if {$NDX && ![string match {[0-9]*} $line]} { continue } # 1st pass (Left): accumulate ALL the headers as a list ... if {$LR == "Left"} { lappend d3Left(hnks) "[extract $line]" # ... but also detect that first entry (& init onetime vars) # while ALSO tracking the max size of the list we build if {[set maxLh [llength $d3Left(hnks)]] == 1} { upvar 0 d3Right CH; # Presume Right is initial CUR Hunk set CH(nxt) "break" set CH(swap) "d3Left" set CH(self) "d3Right" lassign {0 0 ? 0} CH(s) CH(e) CH(m) CH(cv);# init stage upvar 0 d3$LR MH ; # Presume Left is initial MAP Hunk set MH(nxt) { set d3Left(hnk) "[lindex $d3Left(hnks) [incr ndx]]"} set MH(swap) "d3Right" set MH(self) "d3Left" lassign {0 0 ? 0} MH(s) MH(e) MH(m) MH(cv);# init stage # Last, "prime" the upcoming while loop w/1st Map Hunk set ndx -1 ; eval $MH(nxt) lassign "$MH(hnk)" MH(s1) MH(e1) MH(s2) MH(e2) MH(typ) } # Dbg puts -nonewline "\n<$LR>$maxLh line($line)" continue # 2nd pass (Right): simply parse this one line (a 1-entry list) } elseif {$NDX} { set CH(hnk) "[extract $line]" # Dbg puts -nonewline "\n<$LR> line($line)" # 3rd pass (Left): Flip one FINAL time & map remaining(?) Lefts # # N.B.: CH & MH are aliases to the LOCAL d3Left/d3Right arrays # (our data structure). Each ALWAYS refers to only ONE of the # arrays, but are OFTEN exchanged so the coding can adhere to # the notion that the CURRENT hunk (CH) is the one BEING # mapped and (MH), the MAPPING hunk (from the other array), # supplys the critical data needed to do so. } else { # Dbg puts -nonewline " *** FINAL CH MH swap ***" upvar 0 $MH(swap) MH $CH(swap) CH} # Process BOTH diff headers IN TANDEM to create the Markings # # Odd control test is yet ANOTHER "sneak path" to permit # this (at first a) conventional "while" to LATER operate (if # needed) as a NON-loop (triggering code is just BEYOND loop) # The technique is a variation on "Dynamic Programming" while {$ndx < $maxLh || $ndx > $maxLh} { lassign $CH(hnk) CH(s1) CH(e1) CH(s2) CH(e2) CH(typ) # EARLIER hunk (in Ancestor nums) is expected to BE the one # mapped (CH); SHOULD we exchange (L<->R) to achieve that ? # (*ONLY* if we are in NEITHER "flush" mode [per if-tst]) if {$NDX && $ndx < $maxLh && $CH(s1) > $MH(s1)} { # Dbg puts -nonewline " *** Semantic CH MH swap ***" upvar 0 $MH(swap) MH $CH(swap) CH } # Chk the DEL portion for collisions with EITHER another # DEL (from the opposite side) -OR- an ADD in the SAME side # (we designate these as Del->Del or Del->Add respectively) if {$CH(typ) != "a"} { # Dbg puts -nonewline "\n\tDel\t\tNDX($NDX) \ CHhunk($CH(hnk)) ndx:maxLh($ndx<>$maxLh) CH($CH(self))" set E [expr {$CH(e1) - $CH(s1)}] ;# get span of Cur del # Next, compute its MAPPED startpt PRESUMING the # maphunk(MH) is BEYOND us in ancestral ordering ... set S [expr {$CH(s1) + ($MH(s2) -($MH(typ) != "d")) - ($MH(s1) -($MH(typ) != "a"))}] # ...BUT, if that presumption was wrong, further adjust # the mapping by the distance spanned of that maphunk if {$CH(s1) > $MH(s1)} { incr S [expr {$MH(s1) - $MH(e1) -($MH(typ) != "a") \ + $MH(e2) - $MH(s2) +($MH(typ) != "d")}] } # Finally, we can finish the mapping by both setting # its endpt, and the needed "conversion factor" (CV) # that permits us recovering its ancestral numbering. incr E $S set CV [expr $CH(s1) - $S] ######################################### # NOW the FUN ... manufacturing SEQUENTIAL marker data # # Deletions pose an issue as you cant really mark a line that # isnt there. BUT, the line MIGHT exist on the other side (L/R) # IFF it so happens that it was never deleted by any of the # "other side" hunks! # So what we need now is to COMPARE the deletions from BOTH # sides, eliminating those they have in common, and manufacture # markers for the rest. The trick is we have to compare using # ANCESTRAL values, but POST the marks in (L/R) numbers (hence # the CV value!). # Marks are simply an ascending LIST of inclusive line num # pairings (and a displayable UPPERCASED marker char) that # describes lines within that range as "NOT deleted" as they # WERE by the opposing side. Mark numbers are side-specific! # # Ready? # We find collisions by comparing the MOST RECENT range posted, # against that which we are ABOUT to post. This clearly means # we MAY have to BOTH edit the PRIOR posting in addition to the # one in progress (be it an Add or a Del). ALL possibilities # exist: do nothing, eliminate both or either or NEITHER, even # splitting 1 into 2, and inserting the 3rd inbetween. # To evaluate which, we perform a modified version (a single # dimension) of a Cohen Sutherland CLIP Alg. (hCLIP) to quickly # identify 1 of 9 possible situations, and then simply switch # among those possibilities. Using the following mnemonics: # arg1 S: Segment startpt ALWAYS the curr Segmnt # arg2 E: Segment endpt # arg3 RS: Range startpt ALWAYS the prior Mark # arg4 RE: Range endpt # # The 9 hCLIP-encoded proc result specifys these relationships: # 0 : S >RS and E RS and E>=RE # 5 : S =RE and E>=RE # 6 : S<=RS and E>=RE # 10 : S<=RS and E =RS # 7 : (special case RS=RE): S =RS and E >RE # 14 : (special case RS=RE): S $E}\ {set j 0} if {$i != 7} {;# @4 & @5 edit into: s/S-1 set CH(e) [expr $S+$CV-1-$CH(cv)] # @4 & @5: } elseif {$j} {set CH(s) 0} set S $j # (UNFLUSH return code is implicitly coded) } "6" { if {[set j [expr $CH(s)+$CH(cv)-1-$CV]]<$S}\ {set j 0} if {[set i [expr $CH(e)+$CH(cv)+1-$CV]]>$E}\ {set i 0} # After measuring Seg overhangs, # handle having both, either or neither if {$i && $j} { lassign "$S $j \ [string toupper "$CH(typ)"] $CV" \ CH(s) CH(e) CH(m) CH(cv) set S $i } else { set S [incr i $j] } # (UNFLUSH return code is implicitly coded) } }]} then {;# UNFLUSH: # REMOVE end of list and reinstall as staged lassign [lindex $g($CH(self)) end] \ CH(s) CH(e)] CH(m) CH(cv) if {"$CH(s)" == ""} {set CH(s) 0};# <- paranoia set g($CH(self)) [lreplace g($CH(self)) end end] } # YET, if that "prior other side" post was REALLY an Add # then the COMPARISON must be directed TO that other # side to check for a Del->Add collision (but THIS time # using ONLY (L/R) values as Adds simply DO NOT HAVE a # legitimate Ancestral value). } elseif {$MH(s) && [string is lower $MH(m)] && (![set i [hCLIP $S $E $MH(s) $MH(e)]] || \ ($i%4) != ($i/4))} { # Not nearly as difficult as the above Del->Del # Just apply offset needed to get beyond the Add set i [expr $MH(e) - $S + 1] incr S $i incr E $i incr CV -$i;# maintain reference to Ancestral lines } # Post current Del Mark (if it hasn't been editted away) # by 1st FLUSHING the prior STAGED mark ... (if any) # This "staging area" allows us to more easily edit # any individual element without ALWAYS having to "POP" # and "re-stage" an entire entry as we try to modify it. if {$S} { # Flush any presently staged item to its list... if {$MH(s)} {lappend g($MH(self)) \ "$MH(s) $MH(e) $MH(m) $MH(cv)" } # ... then stage (ie. POST) the CUR Del for editting lassign "$S $E [string toupper $CH(typ)] $CV" \ MH(s) MH(e) MH(m) MH(cv) } } # SIMILARLY, check (SAME CURhunk) for an Add component that # maybe collides with an EXISTING Del (posted from the # OTHER side, now on this side, designated as a "Add->Del") if {"[set TYP "$CH(typ)"]" != "d"} { # Dbg puts -nonewline "\n\tAdd\t\tNDX($NDX) \ CHhunk($CH(hnk)) ndx:maxLh($ndx<>$maxLh) CH($CH(self))" # By defn, Add values are NEVER Ancestral, thus have # no need to ever view their comparisons as anything # more than the (L/R) values they ALL posess. set S $CH(s2) set E $CH(e2) set CV 0; # Thus its best if CV remains ZERO # Look for a Del collision on same side as the CUR Add if {$CH(s) && [string is upper $CH(m)] && (![set i [hCLIP $S $E $CH(s) $CH(e)]] || \ ($i%4) != ($i/4))} { ######################################### # There are TWO forms of Add->Del collisions: "push" and "split" # push: is when the Add PRECEDES the Del (but still collides). # Add takes precedence, so Del is "pushed" to be after it. # split: The converse causes the Del to be "split" AT the Add # start, with the remainder of the Del "pushed" after it. # # EITHER WAY, we end up with a MINIMUM of 2 postings (max 3), # but the FINAL 2 are always in 'Add', 'Del' sequence - # which is **NOT THE PRESENT ORDER** ... ######################################## # ... THUS - we FULLY PRE-swap them NOW!! # (which may make reading the entirety of the # switch block feel a bit backward - BE AWARE) lassign \ "$S $E $TYP $CV $CH(s) $CH(e) $CH(m) $CH(cv)" \ CH(s) CH(e) CH(m) CH(cv) S E TYP CV # NOW: CH(*) is the Add....others are the Del # Once again, re-CLIP Add Seg TO an INLINED range # (reasons explained under Del->Del processing) switch [hCLIP $CH(s) $CH(e) $S+1 $E-1] { "0" - "4" - "5" {; # Above cases ALL SPLIT the Del to 2 segs # Flush the LEAD Del portion into the list, lappend g($CH(self)) \ "$S [incr CH(s) -1] $TYP $CV" # Next, calc span of Add Seg, begin to update # start of 2nd Del fragment, and repair CH(s) set i [expr [set S $CH(e)] - [incr CH(s)] +1] # lastly, finish edit to trailing Del startpt incr S } default {; # Remaining cases ALL perform a "push" # Calc span of Add to push Del past it set i [expr $CH(e) - $CH(s) + 1] incr S $i }} # EVERY case then exits thru this common code # (which is completing a half-done 'push') incr E $i ;# update endpt incr CV -$i;# and maintain Ancestral link } # Adds are NEVER "editted", so NO "if S==0" is needed. # Just flush the presently staged Add to the list... if {$CH(s)} {lappend g($CH(self)) \ "$CH(s) $CH(e) $CH(m) $CH(cv)"} # ... then stage REMAINING Del Segment for the future lassign "$S $E $TYP $CV" CH(s) CH(e) CH(m) CH(cv) } # Curr hunk is now mapped ... "increment" to get NEXT one # PROVIDED the Left side is NOT in "flush" mode -OR- # the Right side is STILL flushing... if {$ndx < $maxLh} { eval $CH(nxt) } else break } # Dbl-check WHY we are getting a new RIGHT hunk; if its because # there are NO MORE "Lefts", we are in a "flush Right" state: # Activate the "sneak path" to allow EACH NEXT Right INSIDE # the above "while" loop for a single pass if {$ndx == $maxLh} {incr ndx} } } # Everything has been mapped, simply FLUSH the final staged values if {$diffRC} { lappend g($CH(self)) "$CH(s) $CH(e) $CH(m) $CH(cv)" lappend g($MH(self)) "$MH(s) $MH(e) $MH(m) $MH(cv)" # Dbg puts "" N.B> Uncommenting ALL 'Dbg puts' lines will produce # a TRACE of the Ancestral processing flow (must remove 'Dbg' as # well as Dbg doesn't ACCEPT the "-nonewline" flag: for now anyway) } } if {!$diffRC && $g(is3way)} { # Apparently we EXPECTED to do a 3way, but errors have prevented it! # DROP the 3way state, but ALLOW the 2way to continue (if it can) array unset finfo "a\[ptl]*,$pairnum"; # FORGET about Ancestor request alignDecor $pairnum ; # then RESET state/Decor from 3->2 do-show-Info ; # including room for Ancestral Markers popmsg "Attempted 3way Diff was cancelled\n (due to prior errors)" \ warning "Unable to Comply" } Dbg "Left ancestral datums: [llength $g(d3Left)]" Dbg "Right ancestral datums: [llength $g(d3Right)]" # Mark up the two text widgets and go to the first diff (if there is one). # Otherwise BLANK the combobox (in case it has old data from a PRIOR diff) if {$diffRC} {show-status "Marking differences..."} if {[mark-diffs]} { set g(pos) 1 move 1 0 1 buttons normal } else { $w(combo) configure -commandstate disabled $w(combo) configure -value {} $w(combo) configure -commandstate normal if {"$Statmsg" == ""} { # Unless something FORCED us to not perform/complete the # diff, this HAS to be the reason there just ARE zero hunks! # BUT - dont lie - if there are SUPPRESSED hunks # then it really only APPEARS this way if {$g(COUNT) > $g(count)} { set Statmsg "Files now APPEAR as identical" } { set Statmsg "Files are identical" } } eval after idle {show-status "{$Statmsg}"} buttons disabled } } ############################################################################### # Set the X cursor to "watch" for a window and all of its descendants. # # An optional msg 'WHY' will post to the status area (when BOTH exist); if the # '.status' window DOESN'T exist yet, one **MAY** be temporarily built, and the # reason posted there, PROVIDED it takes longer than a specifiable delay(in ms) # to REACH the code that can cancel the need (ie- the message is only IMPORTANT # if the GUI isn't inplace yet AND the action we elected to be BUSY about takes # randomly longer than someone can withstand waiting for feedback: # Prime example: hung networks or simply unpredictable latency. ############################################################################### proc watch-cursor {{WHY {}} {delay 1250}} { global g w ASYNc # Cant 'busy' out windows that arent't there yet ... if {[winfo exists w(client)]} { . configure -cursor watch $w(client) configure -cursor watch $w(toolbar) configure -cursor watch $w(menubar) configure -cursor watch if {$WHY != {}} {show-status "$WHY"} update idletasks # ... but if we gave a REASON WHY - someone should see THAT reasonably soon } elseif {$WHY != {}} { # Thus we want to REQUEST a status window be built after a short delay; # HOWEVER if we can complete the "busy" task and get back in time to # CANCEL the request, the user need NEVER see it -BUT- that means # changing to ASYNC processing for any external tasks we might spawn or # we will NEVER see the timer fire (it needs a running event loop). # This temp Status window IS removed @pgm exit (on failures), OR as # soon as we replace it with the main GUI (eg. success). Once built, # future Busy/Unbusy pairs simply USE whatever status window exists. if {![winfo exists .status]} { # So post the timer, SAVING its ID in a global whose EXISTENCE # will be used as a flag, so 'run-command' operates in ASYNC mode. # (N.B> but only the first one to get here can actually post) if {![info exists ASYNc(trigger)]} { set ASYNc(trigger) [after $delay need-status "{$WHY}"] Dbg "Posted ASYNc(trigger)($ASYNc(trigger))" } } else { show-status "$WHY" } update idletasks } } ############################################################################### # Give the user SOMETHING to look at while they wait # # N.B> if processing hangs, clicking the window 'exit' decoration will kill pgm ############################################################################### proc need-status {WHY} { global g w set w(status) .status build-status pack $w(status) -side bottom -fill x -expand n wm deiconify . # N.B> Protocol only works IFF event loop is RUNNING (to see 'after' event) show-status $WHY update idletasks } ############################################################################### # Restore the X cursor for a window and all of its descendants. ############################################################################### proc restore-cursor {} { global w ASYNc if {[winfo exists w(client)]} { . configure -cursor {} $w(client) configure -cursor {} $w(toolbar) configure -cursor {} $w(menubar) configure -cursor {} show-status "" update idletasks } elseif {[info exists ASYNc(trigger)]} { # If got here in time ... cancel setting up the status window # Regardless, reset to synchronous IO -- future attempts will either # REMAIN synchronous (w/existing Status window), or retrigger ASYNc if {![winfo exists .status]} { after cancel $ASYNc(trigger) Dbg "Cancelled ASYNc(trigger)($ASYNc(trigger))" } unset ASYNc(trigger) } } ############################################################################### # Check if error was thrown by us or unexpected ############################################################################### proc check-error {result output} { global g errorInfo if {$result && $output != "Fatal"} { error $result $errorInfo } } ############################################################################### # redo the current diff (optionally forcing a semantic [eg. preference] reason) # Attempt to return to the same diff region, numerically speaking. # Force a recompute because of a changed interpretative semantic ############################################################################### proc reCalcD {reason {onoff {}}} { global g opts finfo # Optionally permits forcing a preference setting if {$onoff != {}} { set opts($reason) $onoff } set ndx(1) [set ndx(2) [expr {$finfo(fCurpair) * 2}]] incr ndx(1) -1 #N.B> Silently ignored IFF subject data is missing (SCM untried or failed) if {$finfo(pth,$ndx(1)) != {} && $finfo(pth,$ndx(2)) != {}} { Dbg "Forcing recompute via $reason pref change" set current $g(pos) do-diff move $current 0 1 center } } ############################################################################### # Wipe most everything (data plus widget content), then kick off a rediff ############################################################################### proc do-diff {} { global g w opts errorInfo wipe-window watch-cursor update idletasks unset -nocomplain g(redoDiff) ;# Cancel any PENDING redo (see prefapply) set result [catch { rediff } output] check-error $result $output if {$g(mergefileset)} { do-show-merge 1 } restore-cursor } ############################################################### # Convert from hunk-index # a 1-based monotonic difference position (called a hunk) # to hunk-id # a diff-encoded (nnn[acd]mmm) descriptive format ############################################################### proc hunk-id { ndx {lst diff}} { global g # lst: 'DIFF' (superset diffs) has ALL hunks (inclds IGNORED) # 'diff' (subset diffs) has only REAL hunks # Both lists expect to NOT have a *dummy* index-0 element lindex $g($lst) [incr ndx -1] } ############################################################### # Convert from hunk-id # a diff-encoded (nnn[acd]mmm) descriptive format # to hunk-ndx # a 1-based monotonic difference position (called a hunk) ############################################################### proc hunk-ndx { id {lst diff}} { global g # lst: 'DIFF' (superset diffs) has ALL hunks (inclds IGNORED) # 'diff' (subset diffs) has only REAL hunks # Both lists expect to NOT have a *dummy* index-0 element expr { 1 + [lsearch -exact $g($lst) $id] } } ############################################################################### # Get things going... ############################################################################### proc main {} { global g w opts ASYNc startupError errorInfo tk_version wm withdraw . wm protocol . WM_DELETE_WINDOW do-exit wm title . "$g(name) $g(version)" wm iconphoto . -default deltaGif if {$w(wSys) == "x11"} { # All this nonsense is necessary to use an icon bitmap that's # not in a separate file. toplevel .icw if {[string first "color" [winfo visual .]] >= 0} { label .icw.l -image deltaGif } else { label .icw.l -image delta48 } pack .icw.l bind .icw "wm deiconify ." wm iconwindow . .icw if {[get_gtk_params]} { } elseif {[get_cde_params]} { } else { Dbg "x11 fallback options" set hlbg "#4a6984" set hlfg "#ffffff" #set w(selcolor) $hlbg if {$tk_version >= 8.5} { option add *Menu.selectColor $w(foreground) option add *Checkbutton.selectColor "" option add *Radiobutton.selectColor "" } else { option add *selectColor $hlbg } } } if {$w(wSys) == "aqua"} { get_aqua_params } # Begin by interpolating command args # # 'commandline' will EXIT if args are INCORRECT/INVALID, or pass # control to 'newDiff' if simply missing; EITHER of which will, # in turn, invoke 'assemble-args' to OBTAIN the first (or only) # pairing of actual files to DIFF. If MULTIPLE pairs resulted from # that proc, SUBSEQUENT pairings will be chooseable via the GUI. # Insufficient pairings results in an "Abort". if {[commandline] > 0 || [newDiff]} { if {![assemble-args]} {fatal-error "Insufficeint usable input"} } elseif {![info exists w(NewDok)] || !$w(NewDok)} {do-exit} # The ONLY WAY this exists is if 'assemble-args' was forced # to warn about delayed SCM access time - get rid of it # (and any lingering ASYNC processing condition) if {[info exists w(status)]} { wm forget $w(status) unset -nocomplain ASYNc(trigger) Dbg "ASYNC mode has been dropped" } set g(startPhase) 1 create-display # Evaluate any custom code the user MAY have provided if { "$opts(customCode)" != {}} { Dbg "Custom code IS in use...beware" if {[catch [list uplevel \#0 $opts(customCode)] error]} { set startupError "Error in custom code: \n\n$error" } cfg-toolbar ;# which MAY have tried to set w(selcolor) } # Finally DRAIN anything still pending in the eventloop update do-diff update-display # this forces all of the various scrolling windows (line numbers, # change bars, etc) to get in sync. set yview [$w(RightText) yview] vscroll-sync 2 [lindex $yview 0] [lindex $yview 1] hscroll-sync 1 0 hscroll-sync 2 0 wm deiconify . update idletasks if {[info exists startupError]} { popmsg $startupError warning "Error in Startup File" } } ############################################################################### # Erase tmp files (if necessary) and destroy the application. ############################################################################### proc del-tmp {} { global g foreach f $g(tempfiles) { file delete $f } } ############################################################################### # Put up a window with formatted text ############################################################################### proc do-text-info {win title text} { global g w if {![Dialog NONMODAL $win]} { wm title $win "$g(name) Help - $title" wm transient $win . wm group $win . # we could leave this off (its what TK would do anyway) but... wm protocol $win WM_DELETE_WINDOW "destroy $win" set width 64 set height 32 # grid the button BEFORE its sibling frame # (thus making it LOWER/LATER in the stacking/clipping order) # N.B> Note that the Dismiss button is NOT using a 'ctrlvar' setting # (see explanantion at Bottom of this proc) grid [button $win.done -text Dismiss -command "destroy $win"] \ -row 1 -column 0 -sticky se -pady 5 -padx 5 grid [frame $win.f -bd 2 -relief sunken] -row 0 -column 0 -sticky news grid rowconfigure $win 0 -weight 1 grid columnconfigure $win 0 -weight 1 text $win.f.title -height 2 -width 50 -wrap word -bg white -fg black \ -highlightthickness 0 -bd 0 text $win.f.text -setgrid 1 -width $width -height $height -wrap word \ -padx 20 -bg white -fg black \ -highlightthickness 0 -bd 0 pack $win.f.title -side top -fill x -expand n pack $win.f.text -side left -fill both -expand y if {$g(debug)} { # Silly idea - writing the raw help text out for printing ... # (make the button hide in plain sight); ??convert to manpage?? button $win.write -text {} -relief flat -takefocus 0 -command \ "set pth \[tk_getSaveFile -parent $win.f.text -initialdir {.}] if {\$pth != {}} { puts \[set pth \[open \$pth w]] {$title\n$text} close \$pth}" grid $win.write -row 1 -column 0 -sticky sw -pady 5 -padx 5 } put-text $win.f.title "$title" put-text $win.f.text $text $win.f.title configure -state disabled $win.f.text configure -state disabled update idletasks # Only how big - NOT where to put it! wm geometry $win ${width}x${height} } Dialog show $win } ############################################################################### # centers window 'win' over parent ############################################################################### proc centerWindow {win {size {}} {persist 0}} { update set parent . # Last two optional args are permitted to be in EITHER order # AND can be distinguished by their CONTENT - not just their sequence # (Rearrange them if they were specifed in backward order) if {[llength $size] == 1} { set x $persist ; set persist $size ; set size $x } # What follows here has to do with WHEN the centering was being requested # AND what data might NOT be particularly reliable (such as the dimensions # of the window BEING centered -OR- the parent being centered ON: # 'size' = empty (normal) says: use the data of the windows themselves # = 2 values: use these AS the size of the window TO center # = 4 values: as for =2, but use 3&4 as the PARENT dimensions # Note that if WxH of 'win' has been GIVEN as (0 0) (from either syntax) # that is the same as requesting that the window itself provide its size if {[llength $size] > 1} { lassign [concat $size 0 0] wWidth wHeight pWidth pHeight } if {[llength $size] < 4} { set pWidth [winfo reqwidth $parent] set pHeight [winfo reqheight $parent] } if {[llength $size] < 2 || ($wWidth==0 && $wHeight==0)} { set wWidth [winfo reqwidth $win] set wHeight [winfo reqheight $win] } Dbg "centering(${wWidth}x$wHeight) onto parent(${pWidth}x$pHeight)" # get on with the centering set pX [winfo rootx $parent] set pY [winfo rooty $parent] set centerX [expr {$pX +($pWidth / 2)}] set centerY [expr {$pY +($pHeight / 2)}] set x [expr {$centerX -($wWidth / 2)}] set y [expr {$centerY -($wHeight / 2)}] # Can NEVER set WxH in PIXELS if window is GRIDDED !! Only the location if {[llength $size] > 0 && [wm grid $win]=={}} { wm geometry $win [set ctr "=${wWidth}x${wHeight}+${x}+${y}"] } { wm geometry $win [set ctr "=+${x}+${y}"] } Dbg "Centering has targeted at $ctr above parent @($pX,$pY)" # OK - if I understand this correctly, the geometry request will not ONLY # make the window respond as asked, but will be RETAINED by the window # even THROUGH a 'withdraw'/'deiconify' cycle, thereby REINSTATING that # position - even if the user happenned to drag the window elsewhere AFTER # it had been first displayed as 'centered' (often as a convenience). # But OUR moving the window involves a event, which is WHY: update # has been provided (to LET that event happen). Thus after that completes # and presuming we were not told (via 'persist') to LEAVE it that way, # schedule a near future request to REMOVE that geometry setting, allowing # the window to revert to TRACKing any interactive USER-MADE adjustments. if {!$persist} { after idle wm geometry $win {} } } ############################################################################### # The "New Diff" dialog # In order to be able to enter only one filename if it's a revision-controlled # file, the dialog now simply collects the arguments and sends them through the # SAME argument analyzer used by the command line parser. ############################################################################### proc newDiff {} { global g w finfo opts pref # Snapshot the current state of the primary INPUT variables into a global # location (so that the 'Cancel' button callback can find/restore them) # N.B> only preserves FINFO data (sadly, OTHER chgs will remain active) set g(NDpriorVals) [array get finfo {[fr]*[0-2]}] # Special case: on a SUBSEQUENT invocation, verify that the dialog IS # designated AS 'transient' (which it would NOT have been # if it was the FIRST window to be created. This MUST be # done while the window is "withdrawn" BEFORE redisplaying. if {[winfo exists [set w(newDiff) .newDiff]] && [wm transient $w(newDiff)] == ""} { wm transient $w(newDiff) . } if {![Dialog MODAL $w(newDiff)]} { wm title $w(newDiff) "New Diff" wm group $w(newDiff) . wm protocol $w(newDiff) WM_DELETE_WINDOW { set w(NewDok) 0 } # CAN't start as the FIRST window on Windows if it's made 'transient' # N.B> This is the CAUSE of the above "Special case" adjustment if {[winfo exists .client]} { wm transient $w(newDiff) . } set fSpec [frame $w(newDiff).fSpec -borderwidth 2 -relief groove] # N.B> Widget naming here is constrained by various callbacks... # - 'newDiffBrowse' uses the LAST letter of their pathname to # implement a 'shared directory path' protocol among the TWO # main entry widgets 'e1' and 'e2'; a NON-digit last-char # AVOIDS the protocol, but WILL work for the Ancestor usage; # - Revision labels reflect when their ENTRY is non-null; # - SCM lists dynamically derive from the Entry values, and then # further determines and SETs searchability. # Thus 'scm-updat' callback knows WAY to much about almost everything # Be Carefull!! label $fSpec.l1 -text "FSpec 1:" set w(newDiff,FSpec1) \ [entry $fSpec.e1 -textvariable finfo(f,1) -vcmd {scm-updat scm1 %W %P}] entry $fSpec.er1 -textvariable finfo(rev,1) \ -vcmd [list occupancy [label $fSpec.lr1 -text "-r"] %P] label $fSpec.l2 -text "FSpec 2:" set w(newDiff,FSpec2) \ [entry $fSpec.e2 -textvariable finfo(f,2) -vcmd {scm-updat scm2 %W %P}] entry $fSpec.er2 -textvariable finfo(rev,2) -validate key \ -vcmd [list occupancy [label $fSpec.lr2 -text "-r"] %P] $fSpec.er1 configure -validate key ;# allow validation AFTER .er2 exists $fSpec.er1 validate $fSpec.er2 validate label $fSpec.lA -text "Ancestor:" entry $fSpec.eA -textvariable finfo(f,0) -vcmd {scm-updat lckR %W %P} entry $fSpec.erA -textvariable finfo(rev,0) -validate key \ -vcmd [list occupancy [label $fSpec.lrA -text "-r"] %P] $fSpec.erA validate set mrgopt [frame $fSpec.f4] ;# pre-pack all this label $mrgopt.l4 -text "$pref(predomMrg):" -anchor w radiobutton $mrgopt.r1 -variable opts(predomMrg) -text Left -value 1 radiobutton $mrgopt.r2 -variable opts(predomMrg) -text Right -value 2 pack $mrgopt.l4 $mrgopt.r1 $mrgopt.r2 -side left # Now create the SCM comboboxes + 'labels' (tying them to the entry box) ::combobox::combobox $fSpec.scm1 -editable 0 -listvar finfo(scm1) \ -width 10 -command "scm-updat srch" ::combobox::combobox $fSpec.scm2 -editable 0 -listvar finfo(scm2) \ -width 10 -command "scm-updat srch" checkbutton $fSpec.scm1lbl -offrelief flat -onvalue 1 \ -command "scm-updat set $fSpec.scm1lbl 1" checkbutton $fSpec.scm2lbl -offrelief flat -onvalue 2 \ -command "scm-updat set $fSpec.scm2lbl 2" $fSpec.e1 configure -validate key $fSpec.e2 configure -validate key $fSpec.eA configure -validate key # We need the Browser buttons to fit the COMBINED height of BOTH the # filename entry and revision fields, so pre-pack it into a subframe set Brws1 [labelframe $fSpec.fB1 -text "Browse..."] button $Brws1.bf -borderwidth 1 -highlightthickness 0 -image \ txtfImg -command [list newDiffBrowse "File" $fSpec.e1] button $Brws1.bd -borderwidth 1 -highlightthickness 0 -image \ fldrImg -command [list newDiffBrowse "Directory" $fSpec.e1] pack $Brws1.bf -padx {7 0} -pady {0 2} -side left pack $Brws1.bd -padx {0 7} -pady {0 2} -side right set_tooltips $Brws1.bf {"to a file"} set_tooltips $Brws1.bd {"to a directory"} set Brws2 [labelframe $fSpec.fB2 -text "Browse..."] button $Brws2.bf -borderwidth 1 -highlightthickness 0 -image \ txtfImg -command [list newDiffBrowse "File" $fSpec.e2] button $Brws2.bd -borderwidth 1 -highlightthickness 0 -image \ fldrImg -command [list newDiffBrowse "Directory" $fSpec.e2] pack $Brws2.bf -padx {7 0} -pady {0 2} -side left pack $Brws2.bd -padx {0 7} -pady {0 2} -side right set_tooltips $Brws2.bf {"to a file"} set_tooltips $Brws2.bd {"to a directory"} set Brws3 [labelframe $fSpec.fB3 -text "Browse..."] button $Brws3.bf -borderwidth 1 -highlightthickness 0 \ -image txtfImg \ -command [list newDiffBrowse "File" $fSpec.eA "Ancestor"] pack $Brws3.bf -side top set_tooltips $Brws3.bf {"to a file"} # we'll use the grid geometry manager to get things lined up right... grid $fSpec.l1 -sticky e -row 0 -column 0 grid $fSpec.e1 -columnspan 4 -pady 4 -sticky nsew -row 0 -column 1 grid $fSpec.scm1lbl -sticky e -row 1 -column 0 grid $fSpec.scm1 -sticky e -row 1 -column 1 grid $fSpec.lr1 -padx {5 0} -row 1 -column 2 grid $fSpec.er1 -row 1 -column 3 grid $Brws1 -rowspan 2 -padx 4 -pady 4 -sticky nsew -row 0 -column 5 grid $fSpec.l2 -sticky e -row 2 -column 0 grid $fSpec.e2 -columnspan 4 -pady {8 4} -sticky nsew -row 2 -column 1 grid $fSpec.scm2lbl -sticky e -row 3 -column 0 grid $fSpec.scm2 -sticky e -row 3 -column 1 grid $fSpec.lr2 -padx {5 0} -row 3 -column 2 grid $fSpec.er2 -row 3 -column 3 grid $Brws2 -rowspan 2 -padx 4 -pady 4 -sticky nsew -row 2 -column 5 # N.B> Padding Ancestor label reserves spacing for scm(N)lbl checkboxes grid $fSpec.lA -padx {12 0} -sticky e -row 4 -column 0 grid $fSpec.eA -columnspan 4 -pady {8 4} -sticky nsew -row 4 -column 1 grid $fSpec.lrA -row 5 -column 2 grid $fSpec.erA -row 5 -column 3 grid $Brws3 -rowspan 2 -padx 4 -pady 4 -sticky nsew -row 4 -column 5 grid $fSpec.f4 -columnspan 4 -pady 4 -sticky w -row 6 -column 0 grid columnconfigure $fSpec 1 -weight 1 grid columnconfigure $fSpec 4 -weight 4 set options [frame $w(newDiff).options -bd 2 -relief groove] button $options.more -text "More" -command open-more-options checkbutton $options.cflct -text "input is Conflict format" \ -var g(conflictset) label $options.ml -text "Merge Output" entry $options.me -textvariable g(mergefile) label $options.l1l -text "Label for File 1" entry $options.l1e -textvariable finfo(ulbl,1) label $options.l2l -text "Label for File 2" entry $options.l2e -textvariable finfo(ulbl,2) grid $options.more -column 0 -row 0 -sticky nw grid columnconfigure $options -0 -weight 0 # here are the buttons for this dialog... set btns [frame $w(newDiff).buttons] button $btns.ok -text "Ok" -width 5 -default active -command { # CANT claim its a conflictfile it it ISNT a file at all if {![file isfile $finfo(f,1)]} {set g(conflictset) 0} # Because of the call-semantics for 'assemble-args', ALL # Fspecs (f,0 f,1 & f,2) MUST NOT leave here w/VERSIONED # URLs ... (vrsn(s) were ALREADY diverted properly elsewhere) foreach x "f,0 f,1 f,2" { if {[regexp {^[^/]+://[^/]+/.*?@[0-9]+$} $finfo($x)]} { set finfo($x) "[string trimright \ "[string trimright "$finfo($x)" "0123456789"]" "@"]" } } set w(NewDok) 1 } button $btns.cancel -text "Cancel" -width 5 -default normal -command { if {! [winfo exists .client]} {do-exit} array set finfo $g(NDpriorVals) ;# restore start values set w(NewDok) 0 } pack $btns.ok $btns.cancel -side left -fill none -expand y -pady 4 # pack this crud in...(btns FIRST so resize wont clip them) pack $btns -side bottom -fill x -expand n pack $fSpec -side top -fill both -ipady 2 -ipadx 20 -padx 5 -pady 5 pack $options -side top -fill both -ipady 5 -ipadx 5 -padx 5 -pady 5 bind $w(newDiff) [list $btns.ok invoke] bind $w(newDiff) [list $btns.cancel invoke] } # initialize dialog set g(scmDOsrch) 0 ;# Begin from a non-search SCM state set g(scmPrefer) "$opts(scmPrefer)" ;# and w/default SCM preferences $w(newDiff,FSpec1) validate $w(newDiff,FSpec2) validate set detectMrgFilChg $g(mergefile) ###### Dialog show $w(newDiff) w(NewDok) 0 $w(newDiff,FSpec1);# MODAL: wait here ###### Dialog dismiss $w(newDiff) # Only lock-in Mergefile if user CHANGED and ACCEPTED it if {$w(NewDok) && $g(mergefile) != "" } { set g(mergefileset) [expr {$g(mergefile) != $detectMrgFilChg}] } return $w(NewDok) } ############################################################################### # Specialized handler for dynamic SCM state/choice transitions within NewDiff # N.B> (it knows ALOT about the NAMING of the widgets it manipulates) ############################################################################### proc scm-updat {subcmd wdg val {recurs 0}} { global g w opts finfo # Create some useful meta-pgming conversions set Other([set Other(2) 1]) 2 ;# (a simple meta-pgm identity value) if {[string is digit [set ndx [string index $wdg end]]]} { # grab the instance number of widget (if any); then use it # to create meta-addressable names for PAIRED widgets set W($ndx) $wdg set W($Other($ndx)) [string replace $wdg end end $Other($ndx)] } # Overall this implements a 'ripple effect' starting from an 'entrybox' # validation to load a 'combobox' list of detected SCMs (whose value MAY # then be "searchable") to a checkbutton that ASKs for such searching. # Also each widget along the way can initiate its OWN ripple independently switch -glob $subcmd { "scm\[12]" { set finfo($subcmd) [scm-detect $val None] set scmbox [file rootname $wdg].$subcmd ;# matching SCM widget # We WANT the command to fire (to update its srch state) # but only AFTER this callback completes (so we can see result) set vote [lindex $opts(scmPrefer) $ndx-1] ; after idle \ $scmbox configure -value "{[scm-elect $finfo($subcmd) $vote]}" # We also need to alert the user about USING the 2nd slot widget # when the 1st is still empty -> highlight 2nd widget bkgnd. if {($ndx==2 && "$val" != "" && ![$W(1) index end]) \ || ($ndx==1 && "$val" == "" && [$W(2) index end])} { $W(2) configure -bg Tomato } else { $W(2) configure -bg [$W(1) cget -bg] } # Finally, if the data happens to be a Rev-carrying URL we # need to lockout the user from its version-widget. Sadly, TCL # wont *do* a "switch fallthru" case, so we will recurse to it! return [scm-updat lckR $wdg $val] ;# (Always returns TRUE) } "lckR" { set rWdg [file rootname $wdg].er$ndx ;# (gonna need this) # If the present Fspec value appears to be a URL of the # (admittedly, for NOW) Subversion syntactic variety... if {[regexp {^[^/:]+://[^/]+/.+} $val]} { # ...AND has chosen to specify the REVISION suffix ... if {[regexp {@([0-9]+)?$} $val na rev]} { # ... PUSH that revision value into ITS widget and # PREVENT any user manipulation thru that mechanism set [$rWdg cget -textvariable] $rev $rWdg configure -state disabled } { $rWdg configure -state normal } } elseif {[$rWdg cget -state]=="disabled"} { set [$rWdg cget -textvariable] "" ;# zap old URL-provided Rev $rWdg configure -state normal } return true ;# validation is ALWAYS true - we are monitoring only } "srch" { lset g(scmPrefer) $ndx-1 "$val" ;# Keep working global up-to-date # Cant search when ANY Fspec exists or a non-detected SCM if {[$w(newDiff,FSpec1) index end] \ || [$w(newDiff,FSpec2) index end]} { set wdg [string range $wdg 0 end-1] foreach lbl "1lbl 2lbl" { $wdg$lbl configure -text " SCM :" -indicatoron 0 $wdg$lbl deselect } # Otherwise srch is determined PER CHOSEN SCM for each Fspec } else { if {$val in $g(scmSrch)} { ${wdg}lbl configure -text "Search?" -indicatoron 1 } else { # Chosen SCM cant handle searching - remove option ${wdg}lbl configure -text " SCM :" -indicatoron 0 ${wdg}lbl deselect } # MAY need to reactivate OTHER side (if Fspecs JUST went empty) # (N.B> recurs flag prevents nasty endless ping-pong loop) if {!$recurs} { scm-updat srch $W($Other($ndx)) \ [$W($Other($ndx)) cget -value] 1 } } } "set" { # If allowed, USER chooses whether to SEARCH the SCM for candidates if {[$wdg cget -indicatoron]} { # 'val' here is which SIDE was toggled - merge its NEW VALUE # adjusting the other side to establish the radio-like value if {($val & $g(scmDOsrch))} { incr g(scmDOsrch) -$val ;# Turn choice OFF } else { set g(scmDOsrch) $val ;# Turn choice ON ... but [file rootname $wdg].scm$Other($val)lbl deselect; # N.B> Only ONE choice can be ON (but BOTH can be OFF) } # Un-toggle (ie. ignore THIS invocation) if indicator was NOT shown # (means they clicked on it when it wasn't "armed" to accept) } else {$wdg deselect} } } } ############################################################################### # Disables the LABEL (wdg) when the ENTRY value (newV) is empty ... # (primarily a GUI feedback trick to discern an EMPTY field from BLANKS) # # BUT also used to monitor the main PAIR of Rev entry-widgets to warn the user # about using #2 w/o using #1 (because 'assemble-args' might then IGNORE #2) ############################################################################### proc occupancy {wdg newV} { # (grab the instance number of widget - doesn't apply when there ISNT one) if {[string is digit [set ndx [string index $wdg end]]]} { set Other([set Other(2) 1]) 2 ;# (a simple meta-pgm identity value) # And then derive meta-addressable names for BOTH entry widgets set W($ndx) [file rootname $wdg][string map {l e} [file ext $wdg]] set W($Other($ndx)) [string replace $W($ndx) end end $Other($ndx)] # finally adjusting the bkgnd of #2 if it is USED when #1 is empty if {($ndx==2 && "$newV" != "" && ![$W(1) index end]) \ || ($ndx==1 && "$newV" == "" && [$W(2) index end])} { $W(2) configure -bg Tomato } else { $W(2) configure -bg [$W(1) cget -bg] } } # Simple check of the entry value determines STATE of its (provided) label if {[string length $newV]} { $wdg configure -state normal } else { $wdg configure -state disabled } return true ;# validation is ALWAYS true - we are monitoring only } proc open-more-options {} { global w set W $w(newDiff).options grid $W.cflct -row 0 -column 2 -sticky w grid $W.ml -row 1 -column 1 -sticky e grid $W.me -row 1 -column 2 -sticky nsew -pady 4 -padx {0 4} grid $W.l1l -row 2 -column 1 -sticky e grid $W.l1e -row 2 -column 2 -sticky nsew -pady 4 -padx {0 4} grid $W.l2l -row 3 -column 1 -sticky e grid $W.l2e -row 3 -column 2 -sticky nsew -pady 4 -padx {0 4} grid columnconfigure $W 2 -weight 1 $W.more configure -text "Less" -command close-more-options set x [winfo width $w(newDiff)] set y [winfo height $w(newDiff)] set yi [winfo reqheight $W] set newy [expr $y + $yi] if {[winfo exists .client]} { centerWindow $w(newDiff) } else { update } } proc close-more-options {} { global g w finfo set W $w(newDiff).options grid remove $W.cflct $W.ml $W.me $W.l1l $W.l1e $W.l2l $W.l2e # Zap everything as we close (yes, the last 3 get "") lassign {0 0} g(conflictset) g(mergefileset) g(mergefile) \ finfo(ulbl,1) finfo(ulbl,2) $W.more configure -text "More" -command open-more-options } ############################################################################### # File/Directory browser for the "New Diff" dialog ############################################################################### proc newDiffBrowse {type widget {title {}}} { global w opts # Uses TARGET widget name to locate OTHER widget field (expects a 1 or 2) if {[string is digit [set n [string index $widget end]]]} { set widgroot [string range $widget 0 end-1] set other([set other(2) 1]) 2 } else { set n {} } # Start from what is IN the target already # Basically we want each item to START browsing from where # the most recent request left off; that means (in order): # - the directory of where it is already # - the directory of where the OTHER entry is (widgets 1 & 2 only) # - the current working directory # Note that the PRIOR use of EITHER item CAN itself BE a directory if {[set entrystuff [$widget get]] != ""} { if {![file isdirectory [set initdir $entrystuff]]} { set initfil [file tail $initdir] set initdir [file dirname $initdir] } else {set initfil {}} } elseif {$n!={} && [set entrystuff [${widgroot}$other($n) get]] != ""} { if {![file isdirectory [set initdir $entrystuff]]} { set initfil [file tail $initdir] set initdir [file dirname $initdir] } else {set initfil {}} } else { set initdir [pwd]; set initfil {} } Dbg "initdir($initdir) initfil($initfil)" # What KIND of entry are we browsing to find ? switch -glob $type { "D*" { set chosen [tk_chooseDirectory -title "$type ${n}${title}" \ -parent $w(newDiff) -initialdir $initdir] # ?BUG? Undocumented Behavior (at the very least) - # When NO EFFECTIVE manipulation occurs: the dialog 'OK' # button returns "initdir" ... but 'Cancel' returns "" # In keeping with TRYING to 'shorten Fnames', we will use # the CWD when 'initdir' (or the user) happens to steer there if {$chosen==[pwd]} { set chosen "." } } "F*" { set chosen [tk_getOpenFile -title "$type ${n}$title" \ -parent $w(newDiff) -initialdir $initdir \ -initialfile $initfil -filetypes $opts(filetypes)] } } # Send back what we got (inserted only when it was successful) if {[string length $chosen] > 0} { $widget delete 0 end $widget insert 0 [shortNm $chosen] $widget selection range 0 end $widget xview end focus $widget } else { after idle {raise $w(newDiff)} } return $chosen } ############################################################################### # Split or Combine dialog (modal): adjust CDR bounds & forms EQUIVALENT diff(s) ############################################################################### proc splcmbDlg {Combine} { global g w opts splcmb # (If first time invoked) ... Construct the Dialog window itself) if {![Dialog MODAL $w(scDialog)]} { wm title $w(scDialog) "Adjust Diff Bounds" wm transient $w(scDialog) . wm group $w(scDialog) . wm resizable $w(scDialog) 0 0 wm protocol $w(scDialog) WM_DELETE_WINDOW {$w(scDialog).cncl invoke} # Encode the addressable slots/labels for loading into a 5x3 grid: set row(u) [set col(l) 0] ;# Upper row (or) Left col-pair(0&1) set row(l) 2 ;# Lower row set col(r) 3 ;# Right col-pair(3&4) set lbl(l) "Left Side" ;# (both SIDE labels go in row 1) set lbl(r) "Right Side" ;# set lbl(lu) "Upper Edge" ;# (both EDGE labels go in col 2) set lbl(ll) "Lower Edge" ;# # (Button columns are designed as VERTICALLY-OPPOSED pairings) lassign { 0 0 1 1 3 3 4 4} col(luu) col(lld) col(lud) col(llu) \ col(rud) col(rlu) col(ruu) col(rld) # Now start building the dialog label $w(scDialog).msg ;# Message content will be 'cfg'ed later pack $w(scDialog).msg -side top -padx 4 -pady 4 # Populate the 5x3 grid (logically 3x3, but outer cols span 2 each) frame [set BtnFr $w(scDialog).btn] -relief groove -padx 4 -pady 4 foreach LR {l r} { ;# Left Right SIDE > collectively forms foreach UL {u l} { ;# Upper Lower EDGE > widget names & args foreach DU {d u} { ;# Down Up BUTN > to "splcmb-adj" set nm "." button ${BtnFr}[append nm $LR $UL $DU] -image arroW$DU \ -repeatdelay 750 -repeatinterval 400 \ -command [list splcmb-adj $LR $UL $DU] grid ${BtnFr}$nm -row $row($UL) -column $col(${LR}${UL}$DU) } if {[info exists lbl(${LR}$UL)]} { ;# Edge label label ${BtnFr}[set nm .lB${LR}$UL] -text "$lbl(${LR}$UL)" grid ${BtnFr}$nm -row $row($UL) -column 2 } } label ${BtnFr}[set nm .lB$LR] -text "$lbl($LR)" ;# Side label grid ${BtnFr}$nm -row 1 -column $col($LR) -columnspan 2 } pack $BtnFr -side top -padx 4 -pady 4 # Set up to signal 'tkwait ::scDialogRet' when user has completed task button $w(scDialog).done -command {set w(scDialogRet) 1} ;# -text later button $w(scDialog).cncl -command {set w(scDialogRet) 0} -text "Cancel" pack $w(scDialog).done $w(scDialog).cncl -pady 4 -side left -expand yes # Ensure dialog can be RAISED during its modal-grab if becomes hidden # (Should put this definition elsewhere; someplace more general) bind modalDialog {wm deiconify %W ; raise %W} bindtags $w(scDialog) [linsert [bindtags $w(scDialog)] 0 modalDialog] } { set BtnFr $w(scDialog).btn } # # # # # # # # # # # # # # # # # # # # # # Re-configure Dialog contents for PRESENT usage # Some settings WILL depend on whether mode is "Split" .vs. "Combine" if {$Combine} { $w(scDialog).done configure -text "Combine" $w(scDialog).msg configure -text \ "Use buttons to EXPAND the current diff region" lassign {disable normal} inward outward ;# cmbin btns init state } else { $w(scDialog).done configure -text "Split" $w(scDialog).msg configure -text \ "Use buttons to REDUCE the current diff region" lassign {normal disable} inward outward ;# split btns init state } foreach {b} {luu ruu lld rld} {$BtnFr.$b configure -state $outward} foreach {b} {lud rud llu rlu} {$BtnFr.$b configure -state $inward} # Identify the target CDR, its Line info (and extract its type) lassign $g(scrInf,[set hID [hunk-id $g(pos)]]) S E Pl Ol na Pr Or regexp {[0-9,]*([acd])[0-9,]*} $hID na CDRtyp # # # # # # # # # # # # # # # # # # # # # # Next, establish the 'working set' of data (global splcmb array entries) # Start fresh by flushing any old data and recording the CDR info and ID unset -nocomplain splcmb set splcmb(rnge) [list [list $S $E $Pl $Ol $Pr $Or $hID]] # Also initialize the 'Pad'-lines "jump" table for EACH side # A jump table records pairs of line numbers that correspond to the top # and bottom of a contiguous run of "Pad" lines IN a splcmb(rnge) entry. # Used later in "splcmb-adj" to *jump* past those lines when editting. set splcmb(jl) [set splcmb(jr) {}] if {$Pl} {set splcmb(jl) [list [expr {$E-$Pl+1}] $E]} if {$Pr} {set splcmb(jr) [list [expr {$E-$Pr+1}] $E]} # Hmm, 'Combine' requires a lttle more work - if {$Combine} { # Must RE-derive the ORIGINAL bounds of which this CDR is a SUBSET # (create some temps to work with) set minpos [set maxpos $g(pos)] set nS $S set nE $E # Now try to EXTEND those values OUTWARD as far as they can go while {$minpos > 1} { set nhID [hunk-id [incr minpos -1]] if {$nS == [lindex $g(scrInf,$nhID) 1] + 1} { # Subsume this hunk (it abuts the CDR leading edge) lassign $g(scrInf,$nhID) nS tE tPl tOl na tPr tOr set splcmb(rnge) [linsert $splcmb(rnge) 0 \ [list $nS $tE $tPl $tOl $tPr $tOr $nhID]] if {$tPl} {set splcmb(jl) [linsert $splcmb(jl) 0 \ [expr {$tE-$tPl+1}] $tE]} if {$tPr} {set splcmb(jr) [linsert $splcmb(jr) 0 \ [expr {$tE-$tPr+1}] $tE]} } else { break } } while {$maxpos < $g(count)} { set nhID [hunk-id [incr maxpos]] if {$nE == [lindex $g(scrInf,$nhID) 0] - 1} { # Subsume this hunk (it abuts the CDR trailing edge) lassign $g(scrInf,$nhID) tS nE tPl tOl na tPr tOr lappend splcmb(rnge) [list $tS $nE $tPl $tOl $tPr $tOr $nhID] if {$tPl} {lappend splcmb(jl) [expr {$nE-$tPl+1}] $nE} if {$tPr} {lappend splcmb(jr) [expr {$nE-$tPr+1}] $nE} } else { break } } # splcmb(rnge) now has an ORDERED list of possibly involved hunks; # and ORDERED splcmb(jr/jl) lists - ie. ALL its "jump table" info. # ALSO 'nS' and 'nE' now have the OUTERMOST encompassing EDGE values } else { set nS $S ; set nE $E } # Further adjust the "Combine"-mode buttons if CDR is AT either edge of # the rnge (ie. already sitting at an exterior limit) ... # -OR- further adjust the "Split"-mode buttons if its an "a/d"-type CDR to # disallow adjustment to the ALL "Pad" lines side (its pointless). set btns {} ;# Note: default is that NEITHER adjustment will be required if {$Combine} { if {$S == $nS} {set btns {luu ruu} } if {$E == $nE} {set btns {lld rld} } } elseif {"$CDRtyp" == "a" || "$CDRtyp" == "d"} { if {$Pl} {set btns {lud llu} } if {$Pr} {set btns {rud rlu} } } if {[llength $btns]} {foreach b $btns {$BtnFr.$b configure -state disable}} # Construct the (user modifiable) 'working set' of the PRESENT CDR edges # (semantic indices refer to SIDE and EDGE pairings) # Note that the RELATIONSHIP of these MOVABLE edges to the 'hard limit' # EDGES (defined next) WILL DEPEND on the "Split" .vs. "Combine" mode lassign "$S $E $S $E" splcmb(lu) splcmb(ll) splcmb(ru) splcmb(rl) incr splcmb(ll) ;# Txt-wdg require 'lower' edge specs be 1 lower incr splcmb(rl) # Next, a (static) set of 'hard limits' semantically BRACKETING the edges # This semantic is an ['i'nner/'o'uter -plus- 'u'pper/'l'ower] concept # describing where any given BTN (and its implied EDGE) is HEADING to. # NOTE: this will LATER REQUIRE a mode-specific reverse-mapping # conversion (in "splcmb-adj") that can mirror the distinct edge VALUE # REARRANGEMENT being done here (would've been easy if Tcl had pointers!) lassign "$nS $S $E $nE" splcmb(ou) splcmb(iu) splcmb(il) splcmb(ol) incr splcmb(ol) ;# As before, lower bnds must be BELOW range (for Txt-wdg) incr splcmb(il) # Last config step - setup for the Txt-wdg tagging, ensuring visibility... foreach wdg "$w(LeftText) $w(RightText)" { $wdg tag configure scCDR -background $opts(adjcdr) $wdg tag configure scADD -background $opts(mapins) $wdg tag configure scCHG -background $opts(mapchg) $wdg tag configure scDEL -background $opts(mapdel) $wdg SEE $S.0 ;# N.B> grab will BLOCK scrolling: becomes OUR problem } # ... and now 'paint' the CURRENT (starting) state for the user. # (Note: this ALSO *creates* datums describing the Split/Combine STATE) splcmb-Feedback $Combine # # # # # # # # # # # # # # # # # # # # # # FINALLY ... Display and Invoke the actual Dialog Dialog show $w(scDialog) w(scDialogRet) 0 # # # # # # # # # # # # # # # # # # # # # # # waits here for the user to do their thing ... (tick, tick, tick) # # # # # # # # # # # # # # # # # # # # # # # Continue processing, beginning with taking down the Dialog itself Dialog dismiss $w(scDialog) # ELIMINATE all Dialog-overlaid-tagging in the Text widgets foreach wdg "$w(LeftText) $w(RightText)" { $wdg tag delete scADD scDEL scCHG scCDR } #splcmb-chk data ;# Formatted DEBUG output # And BAIL-OUT if user Cancelled -OR- made no ACTUAL changes # (each movable edge is AT its original STARTING position) if {!$w(scDialogRet) || \ ( ($splcmb(lu)==$splcmb(ru) && $splcmb(lu)==$S) && \ ($splcmb(ll)==$splcmb(rl) && $splcmb(ll)==$E+1) )} { return } # # # # # # # # # # # # # # # # # # # # # # Interpret/process the users interaction # # Factor-out/realign the minor inconsistencies between Split and Combine if {$Combine} { # Among the hIDs within 'splcmb(rnge)', ignore ALL that the user has # chosen to NOT coalesce any portion of BACK within the CDR boundary # (Remember: to discount the implicit +1 of lower EDGE values) foreach {tS tE na tOl na tOr thID} [join $splcmb(rnge)] { if {($splcmb(lu) > $tE && $splcmb(ru) > $tE) \ || ($splcmb(ll)-1 < $tS && $splcmb(rl)-1 < $tS)} {continue} lappend rnge $thID # Realign Numbering to FIRST involved hunk (to init LN(l/r) below) if {[llength $rnge]==1} { lassign "$tS $tOl $tOr" S Ol Or } # Rewrite (promote) the CDR type UNLESS they will ALL agree if {"$CDRtyp" != "c" && "$thID" != \ [regexp -inline "\[0-9,]+$CDRtyp\[0-9,]+" $thID]} { set CDRtyp "c" } } } else { set rnge [list $hID] } ;# However, Split only involves the CDR # Neither mode should EVER evaluate the 'Pad'-side of a "NON-chg" CDR if {"$CDRtyp" == "a"} {set splcmb(l2) 0} if {"$CDRtyp" == "d"} {set splcmb(r2) 0} # (L)ine (N)umbering begins with values just PRIOR to first INVOLVED hunk set LN(l) [expr {$S -$Ol -1}] set LN(r) [expr {$S -$Or -1}] # At the moment, 'rnge' is a list of the INVOLVED hIDs (to be deleted). # Grab its count, to use later in ensuring g(pos) REMAINS a legal value # when the hunks being deleted HAPPEN to be at the high end of g(diff). set minpos [llength $rnge] # Walk each region - forming any NEW "hID"s (into 'rnge') as we go foreach rgn {1 2 3} { set NEWid {} # Skip entire region if BOTH sides empty ... if {!$splcmb(l$rgn) && !$splcmb(r$rgn)} { continue } # ... otherwise process BOTH halves to construct the SINGLE new hID # using a technique that roughly parallels what "mark-diffs" would do # Step through the (D)datum item (bounds and type) for each side foreach LR {l r} { if {$splcmb(${LR}$rgn)} { foreach "bgn($LR) end($LR) typ" $splcmb(${LR}${rgn}D) { # factor out encompassed jump entries (if any) set i 0 foreach {n1 n2} $splcmb(j$LR) { if {$bgn($LR) <= $n1 && $n2 <= $end($LR)} { set i [expr {$i + $n2 - $n1 + 1}] } } # THEN compute number of LOGICAL lines, and MAP the type set sz($LR) [expr {$end($LR) - $bgn($LR) - $i}] set t [string map "CDR $CDRtyp ADD a DEL d CHG c" $typ] switch $t { "a" { append NEWid $LN(l) a [incr LN(r)] if {$sz($LR)} { append NEWid "," [incr LN(r) $sz($LR)] } } "d" { append NEWid [incr LN(l)] if {$sz($LR)} { append NEWid "," [incr LN(l) $sz($LR)] } append NEWid d $LN(r) } "c" {if {"$LR" == "r" } { append NEWid [incr LN(l)] if {$bgn(l) != $end(l)} { append NEWid "," [incr LN(l) $sz(l)] } append NEWid c [incr LN(r)] if {$bgn(r) != $end(r)} { append NEWid "," [incr LN(r) $sz(r)] } } } } } } } lappend rnge $NEWid } # Combine will likely REMOVE more hunks than it ADDS. Ensure g(pos) # REMAINS within its eventual bounds; preferably unchanged # (minpos was earlier set to the number of hunks being removed) set minpos [expr {(-2 * $minpos) + [llength $rnge] + [llength $g(diff)]}] set g(pos) [min $minpos $g(pos)] # Remove and Replace the designated HIDs mark-diffs $rnge update-display } ############################################################################### # Split/Combine dialog button callback: perform edge movement (and update UI) ############################################################################### proc splcmb-adj {side edge btn} { global w splcmb # Only PERMITTED actions can invoke us, so NO CHECKs are EVER reqd # (buttons are enabled/disabled as needed per invocation) # N.B> Args not only describe the action, but also the INVOKING widget Dbg "\n Btn HIT: Side<$side> Edge<$edge> Btn<$btn>" # Invent some static translations to provide "symbolic meta-programming". # Many are basically just 'inverse mappings' indexed by an EDGE or a BTN, # (or a +/- 'btn' move defn). "push" (a predicate) says WHEN # colocated edges MUST move together and is indexed by an EDGE plus a BTN lassign { 1 1 0 0 1 -1 r l l u d u } \ push(ud) push(lu) push(uu) push(ld) mvEg(d) mvEg(u) \ otherS(l) otherS(r) otherE(u) otherE(l) otherB(u) otherB(d) # Recover the semantic MODE we are operating under (because we can't PASS # its value from a widget cmd), then use it to create a CONTEXT-SPECIFIC # mapping from Edge/Btn specs to the 'LIMit edge' each is APPROACHING # N.B> The Combine-mode mapping is NECESSARILY DIFFERENT than Split-mode # Edge - Btn "Combine" "Split" # Upperedge-Up -> Outer-Upper -> Outer-Upper # Upperedge-Down -> Inner-Upper -> Outer-Lower # Loweredge-Up -> Inner-Lower -> Outer-Upper # Loweredge-Down -> Outer-Lower -> Outer-Lower if {[set CS [expr {[llength $splcmb(rnge)] - 1}]]} { set CSmap {uu ou ud iu lu il ld ol} } else { set CSmap {uu ou ud ol lu ou ld ol} } # OK - Extract/categorize the CURRENT edge location values # THEN actually MOVE the designated edge ... # (HOWEVER when in ): IFF both edges WERE coincident, also # conceptually PUSH (really drag) the OPPOSING edge along as well ... # UNLESS the movement logically SEPARATEs the edges (ie. stops pushing) set aLIM $splcmb([string map $CSmap ${edge}$btn]) ;# (a)pproached LIM set bLIM $splcmb([string map $CSmap ${edge}$otherB($btn)]) ;# (b)ehind LIM set oldE $splcmb(${side}$edge) ;# Edge ABOUT to move set oppE $splcmb(${side}$otherE($edge)) ;# (opp)osed Edge # MOVE the EDGE !! set newE [incr splcmb(${side}$edge) $mvEg($btn)] # Special condition (mostly meaningful for Combine): # If moved edge WAS sitting *on* the "Opposite" LIM, its possibly ALSO # a jump entry - so PRETEND we just moved THERE and let jumping fix it. # HOWEVER - This is really all about ensuring we NEVER "jump BACKWARD" by # accidentally STARTing from the "wrong direction" half of a jump tuple. # (because *that* causes an endless-loop toggling jump condition) if {($oldE == $bLIM && [set i [lsearch $splcmb(j$side) $oldE]] >= 0) \ && (($i & 1 && $mvEg($btn) < 0) || (!($i & 1) && $mvEg($btn) > 0))} { set newE $oldE} set i 0 # Check if the move TRIGGERS a "jump": jumping moves to the "other end" # of the jump tuple (which MUST be in the direction we are moving) ... # and THEN moves the edge AGAIN (by 1) UNLESS doing so would exceed the # approaching limit. Barring that, each successful jump forces a new pass, # looking for an ABUTTED jump, until no more exist (or 'aLIM' is found) # N.B> A Split NEVER has abutted entries - Combine may have several while {$i < [llength $splcmb(j$side)]} { set i 0 ;# (start a new pass - ends @ aLIM or when NO jump is found) foreach jmp $splcmb(j$side) { if {$jmp == $newE} { set newE [lindex $splcmb(j$side) [expr {$i & 1 ? $i-1 : $i+1}]] if {$newE == $aLIM} { set i [llength $splcmb(j$side)] set splcmb(${side}$edge) $newE } else { set splcmb(${side}$edge) [incr newE $mvEg($btn)] if {$newE == $aLIM} { set i [llength $splcmb(j$side)] } } break } incr i } } # Also check if moving is "push"ing the opposing edge with it (Split only) if {$oldE == $oppE && $push(${edge}$btn)} { set oppE [set splcmb(${side}$otherE($edge)) $newE] } # Now the FUN - First, readjust which buttons will NOW be available ... set Bwdg $w(scDialog).btn.$side ;# (just conserving src-code typing) if {$newE == $aLIM} { if {$oppE == $aLIM && !$CS} { ${Bwdg}${edge}$otherB($btn) configure -state normal if {$oldE == $bLIM} {;# force revrs-push on as push goes off ${Bwdg}$otherE($edge)$otherB($btn) configure -state normal ${Bwdg}$otherE($edge)$btn configure -state disabled } \ { ${Bwdg}$otherE($edge)$btn configure -state normal } } \ { ${Bwdg}${edge}$otherB($btn) configure -state normal } ${Bwdg}${edge}$btn configure -state disabled } else { if {!$CS && $oppE != $aLIM && $oppE != $bLIM} { ${Bwdg}$otherE($edge)$otherB($btn) configure -state normal } ${Bwdg}${edge}$otherB($btn) configure -state normal } # ... THEN add visual user feedback of what this boundary move MEANT splcmb-Feedback $CS # ADJUST Text VIEW (in the side just changed) so we see what happenned # (user is UNABLE to scroll for themselves ... grab is in force) incr mvEg(u) -1 ;# (modify into a BALANCED horizon envelope) incr newE $mvEg($btn) ;# ensure NEW edge is INSIDE that horizon if {"$side"=="l"} {$w(LeftText) SEE $newE.0} {$w(RightText) SEE $newE.0} } ############################################################################### # Interpret, display and produce a data mapping of the CURRENT moved-edge state ############################################################################### proc splcmb-Feedback {Combine} { global g w splcmb # Begin by UNtagging all Split/Combine highlighting from affected area foreach wdg "$w(LeftText) $w(RightText)" { foreach tag {scCDR scADD scDEL scCHG} { $wdg tag remove $tag $splcmb(ou).0 $splcmb(ol).0 } } # Then put back what belongs based on CURRENT boundary conditions # For Combine, compute the current EFFECTIVE Outer (U/L) bounds; # Split ALREADY knows those bounds - just copy to the local vars if {$Combine} { # Begin by FINDING the outer (u/l) edges of the INVOLVED hIDs # (remember to discount the +1 of the lower edges when comparing) set upper [set lower 0] foreach hunk $splcmb(rnge) { lassign $hunk S E na na na na hID if {($splcmb(lu) > $E && $splcmb(ru) > $E) \ || ($splcmb(ll)-1 < $S && $splcmb(rl)-1 < $S)} {continue} # extract type regexp {[0-9,]*([acd])[0-9,]*} $hID na type # Retain JUST the first and last edge values (and its diff-type) if {!$upper} {set upper $S; set typ(u) $type} if {$E > $upper} {set lower $E; set typ(l) $type; incr lower} } } else { lassign "$splcmb(ou) $splcmb(ol)" upper lower } # Now, arrange ALL edges (working and limits) as 3 top-to-btm # sub-regions, noting which HAS any content (per sub-region, per side). foreach LR {l r} { lassign {0 1 0} splcmb(${LR}1) splcmb(${LR}2) splcmb(${LR}3) set splcmb(${LR}1) [expr \ {[set t(1$LR) $upper] < [set b(1$LR) $splcmb(${LR}u)]}] set splcmb(${LR}2) [expr \ {[set t(2$LR) $splcmb(${LR}u)] < [set b(2$LR) $splcmb(${LR}l)]}] set splcmb(${LR}3) [expr \ {[set t(3$LR) $splcmb(${LR}l)] < [set b(3$LR) $lower]}] #Dbg [join [list \ "<${LR}1>$splcmb(${LR}1) $t(1$LR) $b(1$LR)" \ "<${LR}2>$splcmb(${LR}2) $t(2$LR) $b(2$LR)" \ "<${LR}3>$splcmb(${LR}3) $t(3$LR) $b(3$LR)" ] "\n"] } # Then "paint" (tag) the occupied sub-regions in appropriate MAP colors # based on the LOGICALLY IMPLIED DIFFERENCE of each sub-region pairing # ALSO RECORD (via L/R sub-region 'D'atums) WHICH lines + type was set # # N.B> DECREMENTing 'bottom' values IN-BETWEEN its widget use and the # subsequent recording produces a PURE "screen Lnum" data viewpoint # # Note: The only distinction reqd for 'Combine' is to PREVENT treating # the 'Pad'-only half of region 1&3 'a/d'-type hunks AS data (by turning # the 'occupied' flag OFF ... *AFTER* highlighting for user feedback) foreach rgn {1 2 3} { if {$splcmb(r$rgn) || $splcmb(l$rgn)} { if {$splcmb(r$rgn) && $splcmb(l$rgn)} { if {$rgn == 2} { set tag scCDR if {! $splcmb(r$rgn)} {set tag scDEL} if {! $splcmb(l$rgn)} {set tag scADD} } else {set tag scCHG} $w(LeftText) tag add $tag $t(${rgn}l).0 $b(${rgn}l).0 $w(RightText) tag add $tag $t(${rgn}r).0 $b(${rgn}r).0 incr b(${rgn}l) -1 incr b(${rgn}r) -1 set splcmb(l${rgn}D) \ "$t(${rgn}l) $b(${rgn}l) [string range $tag 2 4]" set splcmb(r${rgn}D) \ "$t(${rgn}r) $b(${rgn}r) [string range $tag 2 4]" } elseif {$splcmb(r$rgn)} { $w(RightText) tag add scADD $t(${rgn}r).0 $b(${rgn}r).0 incr b(${rgn}r) -1 if {$Combine && (($rgn==1 && "$typ(u)"=="d") \ || ($rgn==3 && "$typ(l)"=="d"))} {set splcmb(r$rgn) 0} set splcmb(r${rgn}D) "$t(${rgn}r) $b(${rgn}r) ADD" } else { $w(LeftText) tag add scDEL $t(${rgn}l).0 $b(${rgn}l).0 incr b(${rgn}l) -1 if {$Combine && (($rgn==1 && "$typ(l)"=="a") \ || ($rgn==3 && "$typ(l)"=="a"))} {set splcmb(l$rgn) 0} set splcmb(l${rgn}D) "$t(${rgn}l) $b(${rgn}l) DEL" } } } } ############################################################################### # Primarily code that advises (1|0) on eligibility of hunk for Split/Combine... # ...but also provides a formatted STDOUT data-dump for debugging purposes ############################################################################### proc splcmb-chk {what {pos 0}} { global g splcmb switch -exact -- $what { "split" { # Is dependant on there being MORE than 1 line on EITHER side # N.B> this PREVENTS splitting ANY one-line hunk (incl. "chg"-type) if {$pos <= $g(count) && $g(count) > 0} { lassign $g(scrInf,[hunk-id $pos]) S E Pl na na Pr return [expr {($E - $S) || ($Pl + $Pr > 1)}] } } "cmbin" { # Is dependant on there being some hunk ABUTTED either above/below if {$pos <= $g(count) && $g(count) > 1} { # Grab edge values of the target CDR at 'pos' lassign $g(scrInf,[hunk-id $pos]) S E # Validate and check BELOW target first, then ABOVE - and exit ASAP if {[incr pos -1]} { if {($S - 1 == [lindex $g(scrInf,[hunk-id $pos]) 1])} {return 1} } if {[incr pos 2] <= $g(count)} { if {($E + 1 == [lindex $g(scrInf,[hunk-id $pos]) 0])} {return 1} } } } "data" { if {"$pos" != "0"} { puts "***** $pos" } ;# <-- simply a dump identifier # This is a DRAMATICALLY more READABLE output format!!! puts " EDGES : $splcmb(lu) $splcmb(ll) $splcmb(ru) $splcmb(rl)" puts " AMONG :" foreach {S E Pl Ol Pr Or hID} [join $splcmb(rnge)] { puts "[format "\t%d %d P=%d,%d O=%d,%d %s" \ $S $E $Pl $Pr $Ol $Or $hID]" } puts "\nou $splcmb(ou)" foreach side {l r} { foreach rgn {1 2 3} { if {$splcmb(${side}$rgn)} { puts "\t${side}$rgn $splcmb(${side}$rgn)\t${side}${rgn}D\ $splcmb(${side}${rgn}D)" } else {puts "\t${side}$rgn $splcmb(${side}$rgn)"} } if {"$splcmb(j$side)" != {}} {puts "\t\tj$side $splcmb(j$side)"} if {"$side" == "l"} { if {[llength $splcmb(rnge)] > 1} { puts "iu $splcmb(iu)\n\t(CDR)\nil $splcmb(il)" } { puts "" } } } puts "ol+ $splcmb(ol)\n" } } return 0 } ############################################################################### # All the code to implement the report writing dialog. # N.B> the ONLY "public" subcmd is 'popup'; all others are for INTERNAL usage ############################################################################### proc rpt-gen {subcmd args} { global g w opts finfo report set w(reportPopup) .reportPopup # N.B> we COULD have 'passed' these around, but this was actually clearer # # Need the number of SCREEN lines that exist (either side will do) # (and "F" is simply a static list of FIELD NAMEs we read hunk data into) set maxlns [expr {int([$w(LeftText) index end-1lines])}] lappend F S E P(Left) O(Left) C(Left) P(Right) O(Right) C(Right) switch -- $subcmd { popup { # Put the dialog up on screen if {![Dialog MODAL $w(reportPopup)]} { wm title $w(reportPopup) "$g(name) - Generate Report" wm group $w(reportPopup) . wm transient $w(reportPopup) . wm protocol $w(reportPopup) WM_DELETE_WINDOW {rpt-gen dismiss} # Populate content ... # and perform a ONE-TIME centering ... rpt-gen build centerWindow $w(reportPopup) } # Configure it for this usage unset -nocomplain report(stats) rpt-gen update set report(filename) [file join [pwd] $report(filename)] # The following does NOT return until the *Dialog* is completed Dialog show $w(reportPopup) w(status$w(reportPopup)) 0 # Whether we WROTE or NOT we are done, take down the dialog # (and Reset the filename validity to 'needs check' for next time) Dialog dismiss $w(reportPopup) set report(fnamVetted) 0 } save - dismiss { # RELEASING the 'Dialog show' depends on the asking subcmd # AND if a writing REQUEST was actually permitted/successful if {$subcmd eq "save"} { if {![set rc [rpt-gen write]]} { # DO NOT release the Dialog - # Let user pick a new filename or CHOOSE to bail out! return } } { set rc 0 } set w(status$w(reportPopup)) $rc } update { # Align all GUI elements with current settings lassign {disabled disabled} state(Left) state(Right) if {$report(doSideLeft)} { set state(Left) "normal" } if {$report(doSideRight)} { set state(Right) "normal" } foreach side {Left Right} { foreach item {lnums cmrks text} { $w(reportPopup).cFrm.$item$side configure -state $state($side) } } # Compute the (minimally formatted) stats, posting it TO the dialog, # AND also HOLD onto it for report output (ONCE per dialog usage) if {![info exists report(stats)] || ![string length $report(stats)]} { $w(reportPopup).msg configure \ -text [join [set report(stats) [rpt-gen stats $maxlns]] "\n"] } # Lastly, decide if a 'Bookmark"-style report choice is permitted set bkmOK [expr {[llength $report(BMrptgen)] ? "normal" : "disabled"}] foreach side {Left Right} { $w(reportTextMnu$side) entryconfigure "B*" -state $bkmOK } } stats { # Develop some simple statistical data (for REAL hunks ONLY) lassign { 0 0 0 0 "" 0 0 "" } {*}$F set aCnt [set dCnt [set cCnt [set modLft 0]]] set aTot [set dTot [set cTot [set modRgt 0]]] foreach hID $g(diff) { lassign $g(scrInf,$hID) {*}$F switch -- "[append C(Left) $C(Right)]" { "+" { incr aCnt ; incr aTot $P(Left) ; incr modRgt $P(Left) } "-" { incr dCnt ; incr dTot $P(Right) ; incr modLft $P(Right)} "!!" { incr cCnt ; incr cTot [expr {$P(Left) - $P(Right)}] incr modLft [expr {$E - $S - $P(Left) + 1}] incr modRgt [expr {$E - $S - $P(Right) + 1}] } } } # ... next compute what we can from them ... # (Note: maxlns derived from a WIDGET: has an EXTRA empty line) set sz(Left) [expr {$maxlns - 1 - $O(Left) - $P(Left) }] set sz(Right) [expr {$maxlns - 1 - $O(Right) - $P(Right) }] set pctLft [expr {double($modLft*100) /double($sz(Left)) }] set pctRgt [expr {double($modRgt*100) /double($sz(Right))}] set totsz [expr { $sz(Left) + $sz(Right)}] set totmod [expr { $modLft + $modRgt }] set totpct [expr { $pctLft + $pctRgt }] set effpct [expr {double($totmod*100) / double($totsz) }] # ... then format our findings (kinda NEEDs a MONO font) and ... lappend out "Number of diffs: $g(count)\n" set fmt "%6d regions were %s: %d(net) modified lines" lappend out [format "$fmt" $dCnt "deleted" $dTot] lappend out [format "$fmt" $aCnt " added " $aTot] lappend out [format "$fmt\n" $cCnt "changed" $cTot] set fmt "%6d %s lines were affected: %4.4g %% of %6d" lappend out [format "$fmt" $modLft "Left " $pctLft $sz(Left) ] lappend out [format "$fmt" $modRgt "Right" $pctRgt $sz(Right)] set fmt "%6d %s lines were involved: %4.4g %% or %6.4g %%" lappend out [format "$fmt" $totmod "Total" $totpct $effpct] # send it all back to the caller return $out } browse { set path [tk_getSaveFile -parent $w(reportPopup) \ -filetypes $opts(filetypes) \ -initialdir [file dirname $report(filename)] \ -initialfile [file tail $report(filename)]] if {[string length $path] > 0} { set report(filename) $path set report(fnamVetted) 1 } } write { if {!$report(fnamVetted)} { # Either this was just a default-generated name, or its a name that # was PLAYED with AFTER having BEEN Vetted - either way force user # to confirm and/or alter the name before we trash something. rpt-gen browse if {!$report(fnamVetted)} { return 0 } } # Apparently we are good to go - reset for next time and just DO it set report(fnamVetted) 0 set handle [open $report(filename) w] puts $handle "$g(name) $g(version) report\t\t\ [clock format [clock seconds]]" # Mention the file name(s) ... BOTH unless exactly one is OFF set not([set not(Right) Left]) Right foreach {side} {Left Right} { if {$report(doSide$side) || !$report(doSide$not($side))} { # (N.B> 'alignDecor' left this cookie just for us - pick it up) if {$g(tooltip,${side}Label)!={}} { set mtime [string range $g(tooltip,${side}Label) \ [string first "\n" $g(tooltip,${side}Label)]+1 end-1] } { set mtime "(@ today)" } # Yeah I know the padding seems strange - but it lines # up things (because L/R are 4/5 chars in length, resp.) puts $handle " $side\tfile : $finfo(lbl,$side) $mtime" } } # Stats have already been Computed and Formatted, just include them # (BUT remember to adapt its NL & spacing relative to the report) puts $handle "\n[join $report(stats) "\n "]\n\n" # Translate the GUI setting regarding the DESIRED output format into # something a bit EASIER to use (if not understand -> boolean logic) # Fairly simple - Should output be limited to: # 2 ALL 'D'iff 'R'egions # 1 SPECIFIC 'DR's (those bookmarked) # 0 no DR-related restrictions whatsoever switch -glob $report(doText$side) { "Diff*" { set DR 2 } "Book*" { set DR 1 } default { set DR 0 } } # Pre-Load FIRST PHYSICAL hunk (if any - IGNOREs MAY still exist) # ("H", "skpH" & "pfxH" just track the hunk 'ndx' for use later) # # IMPORTANT: Note we are walking through g(DIFF) not g(diff) !! # N.B. code DETECTs & INTERPOLATEs further hunks AS lines advance if {$g(COUNT) > [set i [set skpH [set pfxH [set H 0]]]]} { lassign $g(scrInf,[set hID [hunk-id [incr H] DIFF]]) {*}$F if {[info exists g(overlap$hID)]} { set C(Left) [set C(Right) "?"]} \ elseif {"$C(Left)$C(Right)" == ""} { incr skpH ;# must account for an 'ignored' hunk } # A 'S'ignificant 'D'iff 'R'egion is one that can LIMIT the output # based on a confluence of chosen MODE and the specific region set SDR [expr {($DR > 1) || ($DR && $hID in $report(BMrptgen))}] } else { lassign { 0 0 0 0 "" 0 0 "" 0 } {*}$F SDR} # Now produce the requested categories of data (if any) if {(!$report(doSideRight) && !$report(doSideLeft))} {set maxlns 0} while {[incr i] < $maxlns} { set out(Left) [set out(Right) ""] foreach side {Left Right} { if {!$report(doSide$side)} {continue} # Waterfall test detects phase of WHERE "$i" falls IN hunk, # thus what SHOULD be displayed (if not 'off' by request) # # N.B> DESPITE coding as loop - this RARELY ever needs to! # It exists ENTIRELY because there is NO 'goto' in Tcl; # thus a 'continue' is the ONLY way to RE-start this code ! while {true} { if {$H > 0 && $i >= $S} { if {$i > ($E - $P($side))} { if {$i > $E} { if {$H < $g(COUNT)} { # Step forward to the NEXT hunk mapping set hID [hunk-id [incr H] DIFF] lassign $g(scrInf,$hID) {*}$F if {[info exists g(overlap$hID)]} { set C(Left) [set C(Right) "?"]} \ elseif {"$C(Left)$C(Right)" == ""} { incr skpH ;# account for 'ignored' hunks } # Establish 'significance' of this NEW region set SDR [expr {($DR > 1) \ || ($DR && $hID in $report(BMrptgen))}] # WHY IS THERE NO goto IN THIS LANGUAGE!!! # # RESTART waterfall: 'i' MIGHT now be INSIDE # newly read-in hunk (supports abutted hunk # defs as created by Split/Combine feature) continue ## (Poor PGMRS is the problem - NOT goto !) } elseif {$P($side)} { # Fixup trailing Lnums when FINAL hunk padded incr O($side) $P($side); set P($side) 0} set LN 1;set CB 0 ;# Is beyond hunk } else { set LN [set CB 0]} ;# A PADDING line } else { set LN [set CB 1]} ;# A DIFF line } else { set LN 1;set CB 0 } ;# Is before hunk break ;# if we reach here, we need NOT go back around!! } # "Diffs Only" or "Bookmarked" acts as a filter, blocking ALL # output UNTIL we are INSIDE a diff region. Else it does NADA! # The derivation of a 'S'ignificant 'D'iff 'R'egion comes # from both the Text mode chosen and the CURRENT region and # was determined earlier as we encountered each region if {$DR} { # If line is OUTSIDE of ANY hunk, SKIP (due to DR mode) if {($LN ^ $CB)} { continue # Watch for the 1st line of ANY Diff (it needs counting) } elseif {$pfxH < ($H - $skpH)} { # if 'significant' - produce a label AND count it # (but count REGARDLESS to keep # correct) if {$SDR} { puts $handle "\nDiff #[incr pfxH] ($hID):" } { incr pfxH ; continue } # But suppress ANY Diff line that is NOT significant } elseif {!$SDR} { continue } } if {$report(doLnums$side)} { if {$LN} { append out($side) \ [format "%*d " $g(lnumDigits) [expr {$i-$O($side)}]] } else {continue} # N.B> LN==0 implys a PAD line (No CMrk/Text can exist) # Thus no need to append ANYTHING more to this line !! } if {$report(doCMrks$side)} { append out($side) [string range \ [expr {$CB ? "$C($side) " : " "}] 0 1] } if {"$report(doText$side)" != " (no text) "} { append out($side) [string trimright \ [$w(${side}Text) get "$i.0" "$i.0 lineend"]] } } if {$report(doSideLeft) == 1 && $report(doSideRight) == 1} { set output [format "%-90s%-90s" "$out(Left)" "$out(Right)"] } elseif {$report(doSideRight) == 1} { set output "$out(Right)" } elseif {$report(doSideLeft) == 1} { set output "$out(Left)" } set output "[string trimright "$output"]" if {[string length "$output"]} { puts $handle "$output" } } close $handle return 1 } build { # The major guts goes inside the "client Frame" (cFrm) # except for buttons (so we can hold onto them during resizing) set cf [frame $w(reportPopup).cFrm -bd 2 -relief groove] set bf [frame $w(reportPopup).bFrm -bd 0] pack $bf -side bottom -fill x -expand n pack $cf -side bottom -fill both -expand y -padx 5 -pady 5 # Apologies, but this REALLY NEEDS a Mono-spaced font!!! pack [message $w(reportPopup).msg -aspect 500 \ -font {"Courier" 11 italic}] -pady 5 # buttons... pack [button $bf.cancel -text "Cancel" -underline 0 -width 6 \ -command {rpt-gen dismiss}] -side right -padx 5 -pady 5 pack [button $bf.save -text "Save" -underline 0 -width 6 \ -command {rpt-gen save}] -side right -pady 5 # client area. # Treat this as a 5-col area, so we can basically spread any # expansion SPACING among the EMPTY columns set col(Left) 1 set col(Right) 3 foreach side {Left Right} { set pickS [checkbutton $cf.pickS$side -command {rpt-gen update}] set lnums [checkbutton $cf.lnums$side] set cmrks [checkbutton $cf.cmrks$side] set mnu [tk_optionMenu [set txt $cf.text$side] report(doText$side)\ "Full Text" "Diffs Only" "Bookmarked" " (no text) "] $pickS configure -text "$side Side" -var report(doSide$side) $lnums configure -text "Line Numbers" -var report(doLnums$side) $cmrks configure -text "Change Markers" -var report(doCMrks$side) # we need this MENU from the above for config ops in subcmd 'updat' set w(reportTextMnu$side) $mnu grid $pickS -row 0 -column $col($side) -sticky w grid $lnums -row 1 -column $col($side) -sticky w -padx {10 0} grid $cmrks -row 2 -column $col($side) -sticky w -padx {10 0} grid $txt -row 3 -column $col($side) -sticky w -padx {10 0} } # the entry, label and button for the filename will get # stuffed into a "file frame" (fFrm) for convenience... frame $cf.fFrm -bd 0 grid $cf.fFrm -row 4 -column 0 -columnspan 5 -sticky ew -padx {0 5} label $cf.fFrm.l -text "File:" entry $cf.fFrm.e -textvar report(filename) -width 30 -validate key \ -vcmd {set report(fnamVetted) 0; return true} button $cf.fFrm.b -text "Browse..." -command {rpt-gen browse} \ -highlightthickness 0 -bd 1 -pady 0 pack $cf.fFrm.b -side right -pady 4 -anchor se -padx 2 pack $cf.fFrm.l -side left -pady 4 -anchor sw -padx 2 pack $cf.fFrm.e -side left -pady 4 -fill x -expand y grid rowconfigure $cf {0 1 2 3} -weight 0 grid columnconfigure $cf {0 2 4} -weight 1 -uniform a } } } ############################################################################### # Report the version of wish ############################################################################### proc about_wish {} { global tk_patchLevel set version $tk_patchLevel set whichwish [info nameofexecutable] set about_string "$whichwish\n\nTk version $version" popmsg $about_string info "About Wish" } ############################################################################### # Report the version of diff ############################################################################### proc about_diff {} { set whichdiff [auto_execok diff] if {[llength $whichdiff]} { set whichdiff [join $whichdiff] set cmdline "diff -v" catch {eval "exec $cmdline"} output set message "$whichdiff\n$output" } else { set message "diff was not found in your path!" } popmsg $message info "About Diff" } ############################################################################### # Throw up an "about" window. ############################################################################### proc do-about {} { global g set title "About $g(name)" set text { $g(name) $g(version) $g(name) is a Tcl/Tk front-end to diff for Unix and\ Windows, and is Copyright (C) 1994-2005 by John M. Klassa. Many of the toolbar icons were created by Dean S. Jones and used with his\ permission. The icons have the following copyright: Copyright(C) 1998 by Dean S. Jones dean@gallant.com http://www.gallant.com/icons.htm http://www.javalobby.org/jfa/projects/icons/ This program is free software; you can redistribute it and/or modify it\ under the terms of the GNU General Public License as published by the\ Free Software Foundation; either version 2 of the License, or (at your\ option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT\ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or\ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License\ for more details. You should have received a copy of the GNU General Public License along with\ this program; if not, write to the Free Software Foundation, Inc., 59\ Temple Place, Suite 330, Boston, MA 02111-1307 USA } set text [subst -nobackslashes -nocommands $text] do-text-info .about $title $text } ############################################################################### # Throw up a "command line usage" window. ############################################################################### proc do-usage {mode} { global g pref set usage { $g(name) may be started in any of the following forms(1-4): (Note that a FILESPEC is either a file, directory or a Subversion- style URL; optional parameters are documented here in [brackets]) (1) Interactive selection of files to compare: tkdiff (2) Plain files: tkdiff FILESPEC1 FILESPEC2 (3) Plain file containing conflict markers: tkdiff -conflict FILE (4) Source control: (any of: AccuRev, BitKeeper, ClearCase, CVS, Git, Mercurial, Perforce, PVCS, RCS, SCCS, Subversion) tkdiff -rREV1 [-rREV2] FILESPEC1 [FILESPEC2] tkdiff [-rREV1 [-rREV2]] (Search: CVS, Git or Subversion) tkdiff OLD-URL[@OLDREV] NEW-URL[@NEWREV] (Subversion) Additional optional parameters: -a ANCESTORFILE -@ REV (of Ancestorfile - if coming from Source control) -o MERGEOUTPUTFILE -L LEFT_FILE_LABEL [-L RIGHT_FILE_LABEL] -I RegularExpression (ignore matched-lines) -B (ignore empty-lines) -1,-2 (preferred default merge side) -d (debugging output) } set usage [subst -nobackslashes -nocommands $usage] set text { Description (any references to GUI elements will be as shown here) Classically speaking, a diff is a directed comparison of two text\ files that describes what would need to be changed to convert the first\ such file content into the second. $g(name) thus groups its parameters\ as specified into a "Left" and "Right" pairing based on their\ repetition on the command line. Thus the first\ FILESPEC encountered is usually the "Left" and the\ next would be the "Right". Revision specifications work similarly. However, $g(name) often infers an argument (be it\ 'Filespec' or 'Revision') to satisfy the need for two items to compare.\ Some inferences are simple, such as when one FILESPEC is a\ FILE, and the other is a DIRECTORY; it infers the same NAMED file from\ the directory as the FILE that was already specified. Similarly, if no\ second FILESPEC is provided, $g(name) will attempt to access\ a Source Code Management system (SCM:\ see below) to provide the missing item, but in this particular case, it\ will ALSO force such item to be the "Left", or first,\ element of the comparison. Beyond this pairing convention,\ each parameter is independent of others on the commandline. Ultimately,\ all "Left" args are collectively used to specify the item(s) to compare\ to item(s) collectively formed by "Right" args. Unfortunately, this\ "pairing" technique can be up-ended somewhat when using URLs\ because of their ability to specify not only a FILESPEC, but also a REV\ simultaneously. $g(name) treats a FILESPEC at a slightly higher\ precedence than a REV when parsing the arguments and it absolutely will\ not fracture a URL@REV which may make it\ challenging as to which entity specified will end up as "Left". However,\ formulating the commandline parameters is, as always, up to you. In the first form(1), $g(name) will almost always present a dialog\ to allow you to choose the files to diff (subject only to a preference\ setting '$pref(autoSrch)' described in the "On Preferences"\ Help page). This dialog, known as the New... Diff dialog, provides an\ interactive means of specifying the majority of command line parameters.\ However, note that while the command line uses repetition to distinguish\ "Left" and "Right" parameter instances, the dialog expects such values\ to be filled in a similar "Left first" order; as a reminder,\ entering a value (such as a FILESPEC or REV) into\ the "second position" while the "first" remains empty will\ result in a red warning highlight of the (possibly) mis-positioned value;\ you may, of course, enter values in any order you wish: it is, after all\ only a reminder. However, simply because you enterred the value into the second\ position, will not ensure that it remains there if you fail\ to populate ANYTHING into the first position. In such a case,\ $g(name) will interpret the given value as belonging to the\ first position and will apply its "pairing" rules accordingly. Another distinction of the dialog is its presentation and adjustability\ of the SCM that will be used if and when the command syntax\ requires one. Where the command line operates purely by preference\ settings, the dialog allows you to adjust the final interpretation\ within the bounds of all presently entered parameters, which\ is to say the dialog will continually readjust as values are enterred\ or removed. One of the clear advantages of the dialog, besides the\ instantaneous reaction to individual argument adjustments, is an ability\ to "Browse" to files or directories, although typing is still valid.\ In contrast to the preference-controlled 'automatic' search mode of the\ command line (see $pref(autoSrch) setting in the\ "On Preferences" Help page), requesting that mode via the dialog is\ handled via a checkbox, that will only be presented when conditions\ indicate it is possible. Please note that most of the "Additional optional parameters"\ are available from the dialog, but are initially hidden from\ view, as they are often not applicable except in special cases. If you\ need to set them, press More to view them but\ do not re-"hide" them (by pressing Less) before\ clicking the OK button on the dialog as hiding them\ ALSO causes them ALL to become completely unset.\ Lastly, those items not provided for within the dialog ('Ignore...'\ settings, etc.), or really ANY of the\ "Additional optional parameters" listed may still be provided on the\ command line without forfeit of invoking the dialog. In the second form(2), either or both FILESPECs may be to a local\ file or directory, or symbolic links to such. When a directory is involved,\ only its contained FILES sharing a common name will be paired together,\ one from each original FILESPEC. Note that this CAN\ produce multiple pairs of files to be Diffed (if both were directories).\ $g(name) remembers all of them, and permits switching among them later.\ However, when trying to use a URL in this form (versioned or\ not), be advised that the OTHER filespec will not be accepted\ as a directory unless such directory is KNOWN to Subversion,\ (ie. the Working Copy). See form(4) below for more details. In the third form(3), a single FILE containing "conflict markers"\ will be split into two (or three) temporary files and used as ordinary\ input by $g(name). Such files can be generated by external tools such as\ "merge", "cvs", "vmrg", or even\ "diff3 -m" and perhaps others. Note that the\ '-conflict' flag is also available on the dialog (via the\ hidden grouping), but the corresponding FILESPEC1\ must then also be an actual FILE, or\ the setting will be ignored. Note that if the conflict file CONTAINS\ appropriate internal "markers" that indicate a THIRD file was involved,\ $g(name) will configure itself to process in what is called,\ 3-Way Diff mode, using the third derived file as an Ancestor. The fourth form(4) is conditional on $g(name) being able to detect a viable SCM\ system (see below). However, make note that if it DOES, it\ may effectively override the first form as described earlier\ (i.e. interactive startup). Presently only "CVS", "Git" or "Subversion"\ SCM systems will behave this way, when invoked with no arguments as is\ suggested in this form as syntactically possible. The determining\ factor (as to accessing the interactive dialog or not) is controlled by\ the preference setting '$pref(autoSrch)', more fully\ described in the "On Preferences" Help page. Source Code Management In all the SCM forms, $g(name) will detect which SCM system(s) are possible.\ This detection supports RCS, CVS and SCCS by looking for a directory\ with the same name, although RCS can also be detected via its ",v" file\ naming suffix convention. It detects and supports PVCS by looking for a\ vcs.cfg file. It detects and supports AccuRev, Perforce and ClearCase\ by looking for the environment variables named ACCUREV_BIN, P4CLIENT,\ and CLEARCASE_ROOT respectively. It detects Git by looking for a .git\ directory, but will only work when started from within a Git work-tree.\ Similarly, Subversion looks for a .svn directory, except when using\ URLs, expecting any FILESPEC to reside within a recognized\ "Working Copy" (WC). Mercurial is supported by\ looking for a directory named ".hg" in the FILESPEC directory\ or any of its ancestor directories, which is also how .git and .svn\ are searched. It is important to recognize that several detections are based on the\ provided FILESPEC(s), or alternately the "Current\ Working Directory" (CWD) where $g(name) was\ invoked, and at times, BOTH. Often this can necessitate invoking\ $g(name) from within the "Sandbox" (a synonym for "WC")\ which are the actual files and directories that the specific SCM is\ actively tracking. This implicit use of the CWD is often instrumental in\ making a given SCM interaction not only detectable, but functional. REV1 and REV2, when given, must be a valid revision value\ for FILESPEC. When the SCM system (RCS, CVS, etc.) is detected\ (see above), but no revision number is given, FILESPEC is\ compared with the "default" revision (as defined by the\ specific SCM); often the most recently checked in. Again, multiple\ pairings may still be possible, if FILESPEC was specified as\ a directory; where each would then attempt to use the same\ revision. For some SCMs, (those that expect every file to have its OWN\ revision, eg. SCCS or RCS) this can be problematic, unless the given\ revision format were to be something interprettable by that SCM as\ universally applicable, such as a "date". Revision values are generally peculiar to a specific SCM. For example, a Git REV\ (see manpage for git-rev-parse) offers several unusual variations: FILE [compare with HEAD by default] -r HEAD FILE [compare with HEAD] -r HEAD^ FILE [compare with parent of HEAD] -r HEAD~5 FILE [compare with 5th parent of HEAD] -r HEAD~20 -r HEAD^ FILE [compare 20th parent and parent of HEAD] -r 29329e FILE [compare with commit 29329e (full/partial SHA1)] -r v1.2.3 FILE [compare with tag (UNTESTED)] $g(name) does not, itself, do anything with the value other than pass it along. Because there are potentially two FILESPECs there can also be two\ distinct SCM systems. Although most people will only ever need to\ deal with one SCM system for a given situation, there IS\ an unusual arrangement possible that has a distinct advantage. For example, presume you use Subversion, or any other network-based\ repository, but will be unable to assure a viable network connection\ for some stretch of time. One solution would be to create a RCS\ subdirectory and post local modifications to it (avoiding the network)\ until such time as you can once again contact the server, at which point\ you can reinstate whichever RCS version you wish to send to Subversion\ using $g(name) to confirm exactly which changes you want current. Even with just a single SCM system, you may have multiple WCs,\ representing perhaps different branches of the same code, and wish to\ fabricate a merged file as a hybrid of the two versions. $g(name) can\ address BOTH simultaneously, thus allowing the hybrid to be constructed. Additionally, some SCM systems provide abilities that can identify which of\ their files are different given only some set of\ desired revisions (including defaulted). $g(name), using its capacity\ for accepting multiple pairings, will attempt to access those utilities\ it knows of to obtain such as an input source. We call this the "search"\ or "inquiry" mode. SCM systems lacking this ability will simply reject\ any provided Revision arguments as inadequate with an error message. Note that given the lack of a FILESPEC in this\ instance, such SCM utilities basically expect the CWD (of, in this case,\ $g(name)) to be within the "WC" of the files they manage.\ Thus the directory where you invoke $g(name) again plays a role, but\ was likely instrumental in getting that SCM to be detected in the first\ place, so should not be an issue. Accordingly, if fewer than two revisions are given\ and the SCM can accomodate it, inferred revisions will be\ supplied (generally the latest or HEAD, or similar). However, note that\ the Git SCM has an unusual arrangement in that an intermediate\ UNNAMED revision (referred to as the 'stage' or 'index') sits between\ the working copy and the last commit; $g(name) will allow you to specify\ this quasi-revision using a revision value of " " (blank) either on the\ commandline or in the GUI dialog. Remember that on the commandline this\ will require quoting (to be parsed correctly), the simplest being "-r ".\ For the dialog, the field label for the revision will be\ dimmed when it is EMPTY, as it would otherwise be difficult to actually\ SEE a legally enterred blank. Finally, when "inquiry" mode is active, it is entirely possible that one\ such detected difference might be a "conflict"ed file, as is\ often created when a prior SCM merge request was not fully completed.\ $g(name) will accept it as such, even when it is one of multiple files\ being provided, and automatically switch into "conflict" or even "3-Way"\ mode when later processing that particular entry, as needed. A quick word about quoting Most command environments, a Unix/Linux Shell for example, offer multiple\ means of quoting (such as single or double quote characters). As a\ general rule, any $g(name) option flag that takes a value\ (such as a REV or others) may be specified as directly\ prefixed to that value, or separated by "white space" (blanks, tabs,\ etc.). However you must not try to pack multiple\ $g(name) flags into a single parameter as they will not be\ recognized as such by $g(name), and would thus likely be passed directly\ to "Diff" or whatever other differencing engine has been configured,\ as is. See the section "The Diff engine" below for further specific rules. Limitations of URLs Besides Subversion being the only SCM to "define" the usage (and syntax) of\ URLs for accessing the remote repository, there are other issues their\ existance causes to the general semantics of $g(name) insofar as their\ tacit use as a FILESPEC. First is their ability to additionally specify\ a revision. $g(name) will ensure that the revision STAYS with the URL,\ even if it means jumbling the apparent commandline order of arguments\ and what that might mean to which entity ends up as 'Left' .vs. 'Right'.\ Separating these aspects ON THE COMMAND LINE, may make predictability\ of what ends up where easier for experienced users. Lastly, because\ $g(name) has no ability (at present) to determine exactly WHAT the URL\ may point at, trying to treat a URL as naming a directory (to take\ advantage of pairs generation, etc.), EVEN IF IT ACTUALLY DOES, will\ not be honored as $g(name) expects the URL to name a FILE! Perhaps this\ may be addressed in the future, but for now - thems the rules! Requesting a 3-Way diff A "3-Way" diff is most often used for merging a file that different people\ may have worked on both independently and\ simultaneously, back into a single file. Just as\ files for comparison are designated with some combination of a FILESPEC\ (and possible REV value), an ANCESTORFILE may be specified as a\ third file using the "-a" option to designate it. To be useful, this file should be a version that closely\ predates BOTH versions being compared/merged. If using an SCM to track\ past versions, also specifying the "-@" option will provide\ the necessary REV value to obtain the proper file. Note however, that\ should $g(name) detect that the Ancestor file happens to be\ identical to EITHER of the other two, "3-Way"\ mode will be discontinued and instead treated as a simple two-file\ comparison. A notification of this happening will be provided. Additional hints With regard to inferred SCM revision fields, invoking $g(name) with no viable\ arguments at all MAY result in either an SCM\ trying to supply such args OR presenting the interactive\ dialog. However, when an SCM is detected and searched, but\ results in not finding any files to compare, only a\ termination message will be produced. It is NOT recommended to specify an\ ANCESTORFILE, MERGEOUTPUTFILE or more than two\ "-L File-label" options when using any form that will resolve\ to more than a single diff pair (i.e. generally when a\ directory FILESPEC is paired against anything but a\ FILESPEC that is a single FILE). It will likely\ produce undesired results, an example of which is outlined as\ follows: When the merge output filename is not specified, $g(name) will present a\ dialog to allow you to choose a name for that file when attempting to\ write it. This is actually the simplest method of operation. If you\ do choose to provide a name (via the command line\ or the New... Diff dialog window) $g(name) will\ try to honor it. But there is a strong possibility you may\ be asked to reconfirm that name OR be presented with an\ entirely new name when you attempt to write to it. This generally occurs\ when $g(name) detects that multiple file pairs are in use, which would\ result in cross associating the single given merge output name to an\ indeterminate file pairing. Thus $g(name) then reverts to "suggesting"\ its own name. Of course, you may at that point then choose\ whatever filename you wish. In a similar fashion, many of the "Additional optional parameters"\ shown are intended for use when $g(name) is invoked to process a\ SINGLE file pair, as was its original historical heritage. As a further note regarding the $g(name) "suggested" merge file\ output names, be advised that $g(name) will try to fabricate a name that\ derives from the filename used in the Left window, unless that file\ itself derives from an SCM system, in which case it will try to choose\ its name from that of the Right window. When BOTH windows represent SCM\ files, it will aim for the current directory that $g(name) was invoked\ from, but the default name chosen would then be based from a fairly\ cryptic tempfile name which almost certainly will need renaming.\ Regardless of the default name presented, you may, of\ course, place the output in any filename you designate. The remaining options perform the following services: Both -B and -I RegularExpression are intended to\ suppress differences from EMPTY or RE-matched lines respectively, and\ you may specify the "-I" option more than once. Each operates\ as described by the GNU Diff documentation, but are part of $g(name)\ itself and NEITHER is passed to the Diff engine (thus making them usable\ by any such engine). The mutually exclusive options -1 and -2 allow\ one to suggest to $g(name) which side (Left or Right, respectively),\ should be chosen during initial read-in as the contributing\ side for any diff region for which $g(name) cannot discern a reason\ (such as in a 3way ancestor-file situation) to choose one versus the\ other. Oftentimes the intent of the merge (back porting, etc.) and\ the order of files on the command line can dictate which file should\ be treated as the contributing "source" for the eventual merge outputs,\ such that the majority of merge choices will be "pre-selected"\ for you. In fact, it is possible to toggle this value\ after-the-fact if you find that the left-to-right order of the\ files did not turn out as you expected; simply invoke\ New... Diff, flip the setting and allow $g(name) to redo that\ difference computation, then proceed to make the fewer number of needed\ choice assignments. Debug output (-d), while not really meant\ for the average user, is simply mentioned here for completeness sake.\ When used, it produces somewhat cryptic textual output via the STDERR\ output stream showing significant status and/or mileposts with varying\ degrees of usefullness to those familiar with the $g(name) internals. Network latency $g(name) does not, itself, require network access to run. However, certain\ SCM systems are based on such technology and can thus introduce delays\ in the processing performed by $g(name). In fact, a network\ outage could even hang $g(name) while waiting for a response. To help combat that possibility,\ particularly at tool startup, $g(name) may alert\ you that such a delay appears to be occurring. A popup status panel, in\ advance of the main $g(name) display, will present messages of\ activities occurring. As long as new activities continue to occur\ (perhaps every few seconds), no action is needed on your part. However, be advised that should the messages stall and you attempt to\ dismiss this panel, you are, in fact, requesting that\ $g(name) ABORT completely. This feedback mechanism is intended to simply provide you with interim\ updates until sufficient information can be obtained to present the main\ display. Under normal conditions, no such messages are needed nor\ produced, and $g(name) will remove the status display itself\ when the main display is ready. The Diff engine (and more quoting) Although $g(name) was designed as a frontend to the classic, UNIX derived,\ "diff" command, there is no specific reason some other utility meeting\ its input/output and invocation requirements cannot be used. Because of\ this, $g(name) can be configured to interoperate with other differencing\ engines, some having perhaps more advanced (or desireable) detection\ methods. The primary requirement for such engines is it must produce what\ GNU Diff calls "normal" diff output format (NOT "Unified"). Accordingly, any option flag having a leading dash that is not\ recognized as a $g(name) option is passed almost untouched\ to your Diff engine of choice. This "pass through" feature permits you to\ temporarily alter the way the Diff engine is called, without\ resorting to a change in your preferences file. However it also means\ that to use, for example, the "-d" option for GNU diff (which\ is a $g(name) option), you would need to pass it using its\ long-form equivalent of "--minimal" (to avoid the mis-interpretation). But as a related issue, trying to pass any option that\ requires a value MAY necessitate an unusual form\ of quoting to preserve syntactically required "white space" characters.\ As noted earlier, if the value portion has NO blanks and is permitted to\ be physically attached to its option flag, no special action is required. But if the value itself requires a "space" -or- must be SEPARATED from\ its option flag by one (to satisfy the parsing rules of the Diff engine),\ then you should pass the entire construct within double quote\ characters, and perhaps even doubly so. As an example,\ GNU diff has an option whose syntax is: -I, --ignore-matching-lines=RE Admittedly, this option is a $g(name) recognized option (at least\ via the "-I" flag) and thus would not be passed on to the engine, but it\ can illustrate the issues involved. Thus if something similar\ WERE to be passed to tell Diff (in this example) to not\ consider any line that starts with a octathorp (#) followed by a space,\ you might think to specify this to $g(name) as either : "--ignore-matching-lines=^# " (or better "-I^# ") or "-I \"^# \" " (or "-I {^# }") Note in each case, the quoting of BOTH the flag and its value\ together. But particularly, in the second form, note the extra\ quoting (done with escaped double quotes or "brace" characters as shown)\ surrounding the value as well; this demonstrates how to pass a flag that\ MUST be separated from the value it passes. Be aware that single\ quotes will NOT work here. The "brace" character is simply the\ lexical mechanism used by the internals of $g(name) to quote its content\ where potential "substitutions" are to be avoided. Without this 'extra'\ quoting as shown, $g(name) would pass the option, but the\ resulting Diff would MISS the trailing blank of the value. The reason is primarily that $g(name) has no understanding of\ any flags being passed to the engine, nor if they might legitimately\ require a value, or need said value to be separated from its flag while\ still preserving any embedded blanks. IMPORTANT NOTE - from a $g(name) perspective, this specific GNU Diff\ option should never be passed to ANY diff engine\ ... it was designed to make the direct output of Diff itself\ more meaningful to a human by simply suppressing what is,\ in reality, actual differences. $g(name) will fail badly if\ you were to perhaps sneak the option to Diff (using its\ long-form flag name). You have been warned. } if {$mode == "cline"} { puts $usage } else { append usage [subst -nobackslashes -nocommands $text] do-text-info .usage "$g(name) Usage" $usage } } ############################################################################### # Throw up a help window for the GUI. ############################################################################### proc do-help {} { global g pref set title "How to use the $g(name) GUI" set text { Layout (Disclaimer: Historically, $g(name) had provided support [meager though\ it was] for Monochrome displays. As of release V5.1, such support has\ been withdrawn entirely. While it is possible to re-instate\ it, the ready availability/cost of Color monitors makes doing so unlikely) The top row contains the File, Edit, View,\ Mark, Merge and Help menus. Note that\ on some platforms, common practice is to relocate this menubar to a\ specific screen location, often the top of the display. This happens\ automatically on such platforms, and is not peculiar to, nor caused by\ $g(name). The second row is a toolbar having diff-region management,\ search, navigation and merge selection tools, each represented by either\ a symbolic image or just text to convey their specialty. Below that are\ labels which identify the contents for each of the two text windows that\ follow just below them. Note that these labels will also\ produce a "tooltip" popup (a brief description) showing the ACTUAL\ filename and its modification time when hovering over it with the mouse,\ provided it is not a tempfile (such as extracted from a SCM). In addition, if an ANCESTORFILE was specified at startup, a\ third label (a small graphic denoting a text file labelled "A") will\ appear between the other two labels. It also will display a tooltip\ indicating its underlying name, and possibly its modification\ time, the latter based (again) on the file not having been\ extracted from an SCM or not. But in reality it is also a\ button that when pressed, will popup a display only\ presentation of that Ancestor file, for those who simply have\ to be able to see it. The left-most text window displays the contents of FILE1, the most\ recently checked-in revision, REV or REV1,\ respectively (as per the startup options described in\ the "On Command Line" help). The right-most window displays the\ contents of FILE2, FILE or REV2,\ respectively. Clicking the right mouse button over either of\ these windows will give you a context sensitive menu with actions that\ will act on the window you clicked over. For example, if you click\ right over the right hand window and select "Edit", the file displayed\ on the right hand side would be loaded into a text editor. Each text\ window is provided with scrollbars, both vertical and horizontal, which\ can be operated independently or synchronously at the users preference.\ And finally, located between the two horizontal scrollbars, is what is\ called a "grip" which can be dragged horizontally with the\ mouse to re-distribute the relative screen space allocated among the\ Left and Right windows themeselves. Following all these MAY be an optional two line window called the\ "Line Comparison" window. This will show the "current line" from each of\ the Left and Right text windows, one on top of the other. This\ "current line" is defined as the line that shows the blinking "insertion"\ cursor, which can be set by merely clicking on any line in either text\ display and/or "driven about" utilizing numerous keyboard accelerators.\ The entire window may be hidden (or requested) by the View\ menu item "Show Line Comparison Window" being chosen, or not,\ as desired. At the bottom of the main display is the Status bar, where tool activity and/or\ informational messages of various sorts will display from time to time.\ At the far right edge of this bar, is a dedicated display of the number\ of difference regions that presently exist (& if any, which is "current"). All difference regions (DRs) are typically highlighted to set them\ apart from the surrounding text, unless the "$pref(tagtext)"\ preference has been deselected. The current difference region,\ or CDR, is further set apart in the Left text window so that\ it can be correlated to its partner in the other (that is, the CDR on\ the left matches the CDR on the right). This "correlation" is most easily\ seen by requesting that the CDR be "centered" in both text windows,\ either on demand: using either the popup menu, toolbar button, or keyboard\ accelerator hotkey; or by choosing an applicable user preference such as\ "$pref(autocenter)", which when paired with\ "$pref(syncscroll)", will cause both Left and Right CDRs to\ always be aligned as well. You can read more about these and\ other preference settings in the Help menu topic\ "On Preferences". Selecting the CDR The CDR can be chosen in a sequential manner by means of the Next\ and Previous buttons. Similarly, the First and\ Last buttons allow you to quickly navigate to the\ first or last CDR, respectively. For random access to the DRs, use the\ dropdown listbox in the toolbar or the diff map, described below. By clicking right over a window and using the popup menu you can select\ Find Nearest Diff to find the diff region nearest the point\ where you clicked, or simply double-click either on or\ near an existing DR, as a shortcut to the same result. For keyboard-centric power users, be advised that causing $g(name) to nominate\ a new CDR will cause the text display "insert" cursor to immediately\ jump to that CDRs first line. Accordingly, you might benefit from making\ some minor adjustments to the "Text widget options" preference\ setting (specifically adding "-insertbackground color" and\ "-insertwidth numberOfPixels") with appropriate values to make\ it easier to see the location of this critical piece of many\ keyboard-based operations. Operations 1. From the File menu: The New... item displays a dialog where you may choose two files\ to compare. Selecting "Ok" from that dialog will diff the two files. Be\ advised that this is the same dialog as may appear when $g(name) is\ started with no command line parameters given, and its described\ behavior there is the same as invoking it from this context (see the\ help topic "On Command Line" for specific details). Next, the\ File List item will only be active when the current $g(name)\ command parameters yeilds more than a single pairing of files to compare;\ pressing it produces a submenu list of the other available comparisons.\ Choosing one re-initializes the display to the file pair thus selected.\ Note that after choosing an item, the background of that item\ will henceforth be red or green when the mouse hovers over that item,\ based on whether that pairing was successfully read into $g(name). When\ no color is shown, that item has NOT yet been accessed.\ File List items may require noticeable time to load\ if the files each represents requires network access to be processed;\ however, once loaded, subsequent reloading is entirely a local task. The\ Recompute Diffs item recomputes the differences between the\ two files whose names appear above each of the two text display windows.\ The Write Report... item lets you create various text report\ files that can contain information content of your choosing from the text\ windows(s). In addition, simply visiting the dialog to compose your\ report will provided detailed statistics on the breadth and complexity of the differences between the current file pair, which will automatically\ be included in any such report created. You may, of course, choose to\ not produce ANY report, and simply view the statistics.\ For more information abou the reports themselves, see the section\ "Report Generation" presented later. Lastly, the Exit item\ terminates $g(name). 2. From the Edit menu: Copy copies the currently selected text to the system clipboard.\ Find pops up a dialog to let you search either text window\ for a specified text string. Ignore CDR allows you to\ designate the present CDR as no longer being of any concern\ whatsoever to $g(name). It can be used for those situations where it\ would be otherwise dangerous to attempt to automatically\ ignore the Diff region by some rule (such as implied by the\ Ignore RE-matched Lines mechanism of the View menu\ described shortly). Split... and Combine... pops\ up a dialog that allows you to rearrange the CONTENT of the CDR to\ isolate specific lines, facilitating specific merge file generation\ goals. It should be noted however, that these last three operations\ ("Split", "Combine", and "Ignore") are LOCAL to $g(name) itself; meaning\ that each represents work performed by you to adjust the\ result of the most recent Diff, generally in pursuit of some\ "Merge" goal. Such work is ONLY VALID until such time as a\ mergefile is written out (to lock the work in place) or a subsequent\ Diff is run by any means to effectively cancel\ such work! See the upcoming sub-heading Merging for further\ info. Edit File 1 and Edit File 2 launch an editor\ on the files displayed in the left- and right-hand panes.\ Preferences pops up a dialog box from which display\ (and other) options can be changed and saved. 3. From the View menu: This menu is organized into a few sections, the first of which deals with\ how the output from the diff engine can be tuned or interpretted.\ Ignore White Spaces toggles whether certain user preference\ defined options should (or not) be used when invoking Diff. Both of\ Ignore Blank Lines and Ignore RE-matched Lines\ in turn, toggle an ability to suppress (basically NOT notice or\ highlight) any difference region identified by the engine that is\ exclusively comprised of the indicated category. Lines that\ otherwise seem to match, but have been "grouped" by Diff into a larger\ difference region are NEVER suppressed. IMPORTANT: toggling any of these settings will cause $g(name)\ to immediately re-invoke the diff engine so as to provide\ the requested interpretation. This will cause the loss of\ any merge work that may have been in progress at that time. In the second section are items controlling what information gets\ displayed within the tool itself. Both $pref(showln) and\ $pref(showcbs) toggle the display of line numbers and\ markers (respectively) in the text displays. Show Diff Map\ toggles the display of the diff map (see below) on or off.\ The Show Line Comparison Window item toggles the display of a\ literal two line over/under "line comparison" window near the bottom of\ the display. As an alternative to that, the two mutually exclusive items\ Show Inline Comparison (byte) or\ Show Inline Comparison (recursive) will display the specific\ interline differences as configurable highlighting directly\ within the Left and Right text displays themselves. You may\ choose any combination, at any time, as suits your comprehension needs. The third section addresses automatic processing that can be performed\ as other interactions in $g(name) take place.\ If Synchronize Scrollbars is on, the Left and Right\ text windows are synchronized i.e. scrolling one of the windows scrolls\ the other. If Auto Center is on, jumping (by whatever means)\ to a new CDR centers that new CDR automatically. Auto Select\ will attempt to designate the diff region currently closest to the\ middle of a scrolled Left/Right text window AS the new CDR;\ however, only when $pref(syncscroll) is also ON.\ Furthermore, if the window is in the process of being manually\ scrolled (via a mousewheel or driving the insert-cursor about the screen\ by way of keyboard actions), Auto Select will continue to\ operate, yet Auto Center (if active) will be temporarily\ suppressed, to avoid fighting over what (or who) should control scrolling. The fourth (and final) section basically reiterates simple navigation\ actions available elsewhere (toolbar, popup menu) for moving among the\ various diff regions. 4. From the Mark menu: The Bookmark Current Diff creates a new toolbar button that will\ jump to the current diff region. The Clear Current Diff Mark\ will remove the toolbar mark button associated with the current diff\ region, if one exists. When created, each is labelled with the index of\ the present CDR (as depicted in the first tool on the toolbar - see\ below). Be advised that during Split or Combine\ operations (described shortly), or ANY operation that would\ recompute one or more DRs, these "bookmark" buttons may automatically be\ cleared, but only when they are directly involved. 5. From the Merge menu: The Show Merge Window item pops up a window with the current\ merged version of the two files. This will be described further in a\ later section called "Merge Preview" below.\ The Write Merge File item (or possibly the\ Write Merge File...) will allow you to save the contents of\ that window to a file. Pay special attention to the existance of those three trailing dots when\ electing to write the Merge File (either here OR from the\ buttons on the dialog itself) - if they are NOT present,\ it means $g(name) already knows what filename to produce,\ (i.e. from the command line) and you will not be given a\ chance to confirm or alter that name. 6. From the Help menu: The About $g(name) item displays copyright and author\ information. The On GUI item generates this window. The\ On Command Line item displays help on the $g(name) command\ line options and syntax, but also includes discussions on topics\ related to tool startup such as initiating a particular run-mode or\ interactively supplying the command arguments. Lastly, user-settable\ preferences help is provided via the On Preferences item. 7. From the toolbar: (Be advised that in these explanations, the button descriptions refer to the\ textual name ON that button as would be seen when\ the user preference to "$pref(toolbarIcons)" is unset.) The first tool is a dropdown list of all of the differences in a standard\ diff-type format. You may use this list to go directly to any diff\ region. Further navigation tools will be described in due turn.\ Proceeding left-to-right, the next tool, Rediff, simply\ re-computes the diff of the CURRENT two files from scratch as if it was\ a new Diff. This could be appropriate if you have invoked an editor on\ either file since starting and now wish to see the net effects of your\ editting. The next tool Ignore will cause the CDR to no\ longer be treated AS a DR; it is a interactive method not\ unlike those that perform a similar service based on command line flags\ that match either a empty or regular-expression defined line. The next\ two tools, Split and Combine, each provide\ complimentary abilities to adjust the boundaries of the CDR. The reasons\ for doing this are further explained in the section below on Merging. The remaining tools on the toolbar consist of the Find tool\ for searching the text for a given word or phrase. This is then followed\ (in order) by groupings of tools dealing with merge choice selections,\ navigation, and lastly a Bookmarking facility for remembering specific\ diff positions so that jumping among them does not require memorization.\ These, among other topics, will now be further detailed. (Editors note: The next physical group of tools ("Merge:")\ will being deferred until after the others, as it is predicated on\ understanding practically ALL of the others and how they may\ interact - besides being a complex topic in its own right). Navigation tools Adjacent to the label Diff:, the Next and\ Prev buttons take you to the "next" and "previous" DR,\ respectively; just as the First and Last buttons\ take you to the "first" and "last" DR. These actions will also\ affect the Merge Window (when displayed). The Center button\ centers the CDRs in their respective text windows. You can also set\ Auto Center in Preferences (or via the\ View menu) to do this automatically for you as you navigate\ through the diff regions. Dont forget that the dropdown list (the first\ tool on the toolbar) ALSO provides movement to any\ DR, as well. Even Bookmarks (explained shortly) can do the same. Keyboard Navigation When $g(name) has the current keyboard focus, you may also use the following\ (global default) keyboard shortcut keys: ^[ (Ctrl-Bracketleft) Load NEXT file pair ^] (Ctrl-Bracketright) Load PREV file pair c Center current diff f First diff l Last diff n Next diff p Previous diff e Load a text editor with the 'current' file ^f (Ctrl-f) Find some specified piece of text ^r (Ctrl-r) Recompute Diffs of current file pair ^q (Ctrl-q) Exit $g(name) immediately 1 Elect Left as the CDR Merge Choice 2 Elect Right as the CDR Merge Choice 3 Elect Left-then-Right as the CDR Merge Choice 4 Elect Right-then-Left as the CDR Merge Choice There are, of course, other keyboard operations that apply as well, such as\ pressing the spacebar to invoke a "button", but those each require the\ concept known as "keyboard focus" to be properly located at the object\ which is intended to respond. The windowing toolkit (Tcl/Tk in our case)\ defines most of these, as it does the means of assigning such\ focus (pressing 'Tab' or 'Shift-Tab') to switch among such items capable\ of responding. However $g(name) DOES add one "extra" operation\ which is: Return Make the closest diff become the CDR where closest means the line closest to the 'insert cursor' in the text\ window having the active keyboard focus. It is important to emphasize that these are only the DEFAULT hotkeys\ as defined by $g(name) before any customizations or applied preferences.\ Prior to Version 5.1, these values (well, most of them) were\ hard-coded and non-customizable. That is\ NO LONGER THE SITUATION! But, due to concerns over accidental\ loss of in-progress work from a simple keypress, the "Control"-modifier\ has been added to the historical bindings of "r" and "q", AS\ defaults; you can, after all, now re-instate them as you see\ fit. See the section entitled "Behavior" under the Help topic\ On Preferences for the details on choosing your own settings. In addition, the cursor keys, Home, End, PageUp and PageDown work as\ expected, affecting the view in whichever text window has the focus.\ Note that, as expected, if $pref(syncscroll) is set in\ Preferences, and the keyboard actions imply scrolling, both\ will scroll simultaneously. Scrolling To scroll the text widgets independently, make sure\ $pref(syncscroll) in Preferences is off. If it is\ on, scrolling either text widget scrolls the other. Scrolling will not\ change the current diff region (CDR) in this condition, nor will it cause\ the Merge Window (if displayed) to scroll. A Mouse scroll-wheel is also\ recognized for scrolling vertically, or, if the Shift key\ is simultaneously pressed, horizontally, as well. Book Marks Located adjacent to the label BkMark:, you can set "bookmarks" that\ identify specific diff regions, primarily for easier navigation.\ To do this, click on the Set bookmark button when the desired\ DR is currently the CDR. It will create a new toolbar button\ that will jump back to this specific diff region when pressed. To clear a diff mark, first make that DR the CDR, then click\ on the Clear bookmark button. Each is labelled with the\ sequence number of the DR it repreents. Note however, that because\ Split or Combine can both manufacture or\ destroy specific DRs, it can become necessary for $g(name) to\ "Clear" a given bookmark. The same can be said for Ignore.\ Only those specific markers involved are affected; however, any marker\ carrying a label beyond any addition or contraction of DRs\ will always have their labels 'adjusted' accordingly to\ maintain their originally designated region association. The actual Bookmark buttons themselves, will appear in whatever remaining\ space exists on the righthand side of the toolbar. However, should you\ create more than the available space can handle, $g(name) will provide a\ pair of "scroller" buttons to enable you to create as many as needed, yet\ still be able to access them as required. These "scrollers" will\ auto-repeat when pressed-and-held with the mouse, deactivating when the\ designated end-of-the-list is reached, and disappearing altogether when\ no longer needed. Bookmarks are created, and are maintained, in the order you\ choose to manufacture them. Thus those created earlier will be nearer the\ Left edge of all bookmarks available. As mentioned earlier, each is\ labelled with the DR sequence number it represents, but if it is\ important to have a more-permanent "identity" for the given\ DR, you can right-click the bookmark and select annotate from\ its popup menu to assign a short description of your choosing. This\ naming, like the default one internally assigned, will be displayed in\ the Status bar whenever the mouse hovers over that bookmark.\ Note however, that despite naming a bookmark, the bookmark is still\ susceptible to being deleted. The other item on the bookmark-button menu, is a toggle,\ in report, that can be used to designate the DR to participate\ (or not) in a specific Write Report... feature that allows you\ to include only those DRs that have been "tagged" for inclusion. In this\ fashion, you can document only the specific changes you choose to\ identify, perhaps to illustrate some particular issue in addressing how\ best to resolve it. Report Generation $g(name) can output various textual forms of the same data as viewed in the\ main display windows. At the present time, this does not\ include the many various forms of "highlighting" rendered by the tool\ directly onscreen. Nonetheless, the data can be assembled in several different combinations from the full text of BOTH (or either) side(s); or only the "difference regions" (again for either side), and even just\ SELECTED DRs (courtesy of the "Bookmark" menu options). When\ presented with the dialog to make your choices, you will also be shown\ statistics on the magnitude of the DRs in various breakdowns. This same\ set of data will form part of the Heading within the report, which also\ includes the file names (with applicable modification timestamps where\ possible) and, of course, the date the report is generated. It is even\ permitted to get just the header information with NONE of the actual\ file content as the output. While an output filename is provided by default, you may retype it OR\ use the Browse... to specify a replacement. Note however that\ regardless of your simply "taking" the default or typing (or RE-typing)\ a replacement, $g(name) will verify that the name provided is "safe" to\ write to, meaning that if it refers to an existing file,\ you will be given the opportunity change or confirm it via the provided\ file browser window. Diff Map The diff map is a graphic index of where all the diff regions exist. It is\ shown in the middle of the main window if Show Diff Map on\ the View menu is on. The map is a miniature of the file's\ DRs from top to bottom. Each DR is rendered as a patch of color;\ initially Delete as red, Insert as green and Change as blue and in the\ case of a 3-way merge, overlap regions, called "collisions" are marked\ in yellow. These colors are simply the defaults provided by $g(name),\ and can be adjusted via the Preferences... item in the\ Edit menu, to perhaps compensate for better contrast or\ spectrum adjustments given other objects onscreen with your particular\ monitor (or simply personal taste). The height of each patch corresponds to the relative size of the diff\ region. A transparent "thumb" lets you interact with the map as if it\ were a scrollbar, and Mouse scroll-wheel actions are fully supported,\ but will be directed to whichever of the two text windows is\ holding the current input focus, if the windows are not synchronized.\ All diff regions are drawn on the map even if too thin to ordinarily be\ visible. For large files with small nearby diff regions, this may result\ in patches overwriting each other, due to scaling issues. Merge Preview To see an ongoing preview of the file that would be written by\ Write Merge File, select Show Merge Window in the\ Merge menu. A separate window will be shown containing the\ preview. It is updated as you select merge choices, and provides markers\ that remind you as to which side (Left/Right) is presently contributing\ its region into the result. Note that when viewing a choice such as the\ Left-side of an "add"-type, or the Right-side of a "del"-type CDR,\ there is nothing to actually display. Additionally, the\ Preview window is responsive to the current $pref(showln)\ preference setting. It is also synchronized with the other text widgets\ when Synchronize Scrollbars is on, at least as far as actions\ that change the CDR, however it does not actually\ scroll in unison with the other windows, primarily because as\ a representation of the eventual Merge file, it does NOT HAVE any of the\ padding lines which accounts for a substantial amount of the\ vertical spacing being scrolled by the other windows. Merging To merge the two files, go through the difference regions (via Next,\ Prev or whatever other means you prefer) and select\ L (for "Left") or R (for "Right"), located\ adjacent to the toolbar Merge: label, assigning which side\ should be used for each. Alternately, the "1" & "2"\ hotkeys will do the same, respectively. The initial selections (after\ invoking Diff) will have already been established by a user preference\ and/or whether a 3way (involving an ancestor file) was performed\ (explained further in the section "3way merging" below). Selecting L means that the the left-most file's version of\ the difference will be used in creating the final result; choosing\ R means that the right-most file's difference is used. Each\ choice is recorded, and can be changed arbitrarily many times.\ If you need pieces from BOTH the Left AND Right versions you may choose\ the LR or RL (Left-then-Right or\ Right-then-Left, respectively) choices instead, but then you\ must remember to eventually edit the merged result AFTER you\ commit it to disk. This might be useful, for example, if both\ variations should exist with additional wording, or in the case of source\ coding, a conditional inclusion macro, surrounding the entire result. To\ commit the final, merged result to disk, choose\ Write Merge File from the Merge menu, or one of the\ Save buttons provided on the dialog (if it is displayed).\ Remember that each of these items may be labelled with a trailing "..."\ if $g(name) is uncertain of what the target filename should\ be, thereby providing a file browser dialog to either specify and/or\ confirm the name. Merging - in more detail Oftentimes, you may find that the "Diff" engine has packed several lines\ worth of differences into a large chunk, simply because it never found a\ common line that BOTH files could agree was the SAME in both\ files. Yet only a SINGLE defined difference region (a CDR)\ can have its Left or Right side chosen for merging at any one time.\ As a side note, "context" and "unified" diff output formats tend\ to exacerbate this problem, and is part of the reason we dont generally\ like them as an input format, although we may consider\ automatically deconstructing them sometime in the future. Nevertheless,\ this is the "problem" that Split or Combine are\ intended to address. Using these tools, you will be permitted to\ repartition the exact lines that should be treated as a distinct\ difference region. In each case, you start from some specific CDR,\ and then either break it apart into smaller pieces ("Split") or\ reassemble it ("Combine") at line boundaries of your choice. A dialog window is provided to oversee the movement of the CDR boundary\ edges, with feedback provided in the Text windows. You need only to\ click on arrows to adjust either or both edges in the Left or Right\ text window displays until satisfied that the NEW CDR\ describes the change content you wish to convey. Be aware these arrow\ buttons will automatically advance if you press and hold\ instead of clicking, making it easier to adjust a large expanse. Note that only legal edge motions are ever permitted,\ and the buttons will automatically deactivate as necesssary. Most\ actions will make a visible change in highlighting as seen in the main\ text windows, except when the movement of a "Split" edge is\ "pushing" against its opposing edge; movement will STILL\ occur, but because the highlighting will have been squeezed shut,\ it will be difficult to determine exactly where the border is. Backing\ off one step however, can help re-establish your present location. As\ the dialog is in complete control of the text windows at this point, it\ will also control scrolling the window as necessary to keep the edge\ being moved visible. When a moving edge gets within two\ lines of the top or bottom of the window, the window will be scrolled\ to maintain that visibility. This can be disorienting when the DR is\ exceptionally large. Once accepted, $g(name) will treat the new difference region exactly\ the same as any other, despite the fact that it appears run together\ with other adjoining regions, having NO common line to separate them.\ The power of this is that two modifications, having NOTHING to do\ with each other beyond proximity, can thus be merged (or not)\ INDIVIDUALLY as needed. Given that many version control\ systems prefer that only those lines pertinent to a specific logical\ change reside in a given 'patch', these features allows the user to\ surgically distinguish one logical change from another. Note that ONLY a previously Split region, can ever be Combined,\ provided you do NOT choose to Ignore CDR\ some portion of it in the interim. Note further that $g(name) will\ always assign each line of the original CDR into an appropriate region\ (creating and/or removing existing regions as necessary), and\ automatically assigning its type (add/change/delete). If you have difficulty envisioning which edges to move to accomplish\ a specific goal, think of the edges as defining 3 individual regions\ per side of data: Above-the-CDR, the NEW CDR, and Below-the-CDR. Then\ remember that changes always flow from the left side to the right. Thus\ when a Left side region has a zero size, the corresponding Right side\ region is being "added". Conversely, if a right-side region describes\ zero lines, the left-side region describes a "delete". Regions that BOTH\ have lines are simply "changes". Note that only REAL lines (those having Line numbers, when shown) are\ ever counted toward the occupancy of the regions. Padding lines\ (displayed to align CDRs on screen) mean nothing despite their being\ highlighted as part of a CDR, and will be stepped over as\ edges are moved. Finally, remember that any changes YOU might\ make to any CDR content is transitory, and only exists within $g(name)\ until the next time any "Diff" is invoked, even a Rediff. This\ suggests that before beginning any merge work, you shoud ensure that all\ settings or menu choices that adjust or interpret the Diff results\ (predominate side, ignored blanks/lines), or worse, those that might\ trigger a new Diff invocation if they are changed,\ have all been configured appropriately. ALL interactive merge work\ (including Split/Combine and Ignore) is transitory until the merge file\ is actually written out, and can not be automatically\ recovered; only reconstructed! 3way Merging A 3way merge, as the name suggests, involves a third file that is expected\ to have been an earlier common version to both\ files presently being compared. Providing this ancestor file\ will cause an icon to appear between the normal Left/Right\ file labels on the display (indicating the mode is in force and\ permitting viewing access if absolutely necessary) and thereby\ allow $g(name) to look backward in time, to address the unique issue of\ intentionally diverged independent modifications (the Left\ and Right files) being merged back together into a single output file. Specifically, $g(name) wants to identify the modifications that\ created the Left and Right variants, with the intention of\ preserving ALL such changes (both sides) into the final\ result, as automatically as possible. Thus, among the Left/Right diffs\ being shown by $g(name), certain lines may, or may not, have been\ modified during their creation from the ancestor. We call these\ ancestral artifacts, and $g(name) will annotate such lines\ using markers to the left of the line numbers (if displayed), denoting\ what kind of modification (add, chg, del) had previously occurred. Note\ that ancestral deletions technically no longer\ exist in their respective Left/Right files, and thus were\ effectively and implicitly embedded into those files at that time. HOWEVER, given the notion that "merging" is supposed to be the proper\ inclusion of BOTH sets of changes, that would\ mean Deletions must also be fully included. Accordingly\ if only ONE side were to delete a specific line, the failure\ of the OTHER side to do the same, suggests that the decision to remove\ the line in one version and not the other is questionable, and is no\ different than the case of Adding a line in one version and not the\ other. Because of this, $g(name) WILL PROVIDE an ancestral\ artifact on lines that were NOT deleted as they were by the\ opposing version; to remind the user that choosing one side versus the\ other when merging is not always just a "simple" choice. To distinguish a "Deletion" artifact from an Additive one, $g(name) will\ display such items in inverse video AND as Capitalized. Just\ remember that the inverse video is signalling that the ancestral\ Deletion - from the other side - decided the line SHOULD BE\ (and has been) removed, while the marked side says the line should\ remain - NOT that you the user should CHOOSE the side with\ the inverse mark to CAUSE the line to be deleted (which it would NOT do). Generally, when ancestral markers show up in ONLY the Left (or Right)\ windows, $g(name) simply responds by choosing that side as the initial\ merge choice for that region (except, obviously, for inverse Deletion\ marks). When BOTH sides show markers of the same\ type (regarding it being Capitalized .vs. NOT Capitalized) $g(name)\ selects the "Right" side as the merge choice, but also declares the\ region as a collision which requires user assistance to solve,\ highlighting it appropriately to draw it to your attention. As a further reminder, it will also highlight within the dropdown list\ of diff regions on the toolbar, which can thus be used to quickly locate\ these problematic areas, simply by scrolling throught the list looking\ for the highlighted items. Despite all automatic attempts to choose the proper merge choice,\ $g(name) does not and can not, itself, resolve arbitrary\ collisions. However, as it turns out, the Split tool, by\ repartitioning the region into distinct smaller regions, can often be\ used to resolve what we call simple collisions by\ ensuring only one side of each split portion carries markers from\ a single side (if possible). At such time, $g(name) will re-assign the\ affected merge choices appropriately, possibly eliminating the entire\ collision altogether. Because of this ability to remove a collision through direct user\ interaction using Split, $g(name) will also presume\ that independently choosing any manually selected merge\ choice, when dealing with a collision region is trying to\ accomplish the same goal, and will remove the primary\ indications (highlighting) of the collision, provided you\ agree via a popup question. Yet note however, that the responsibility in\ that case, is yours; $g(name) has no additional means to actually\ determine if the collision was truely resolved. Note that "resolved"\ regions are only ever de-highlighted from the Left and Right\ windows; the toolbar diff region dropdown list ALWAYS retains which\ regions were formerly collisions unless the region was fully\ resolved via the Split tool. Finally, remember that like all "adjustments" done after having run a\ Diff, all of it is entirely transitory until the Merge output\ file is generated, or another Diff is invoked, by any means. Original Author John M. Klassa Comments Questions and comments may be sent to the TkDiff mailing list at tkdiff-discuss@lists.sourceforge.net. Or directly into the Discussion forum at https://sourceforge.net/p/tkdiff/discussion } do-text-info .help $title [subst -nobackslashes -nocommands $text] } ###################################################################### # display help on the preferences ###################################################################### proc do-help-prefs {} { global g pref set title "$g(name) Preferences" set text { Overview Preferences are preserved in a file in your home directory (identified by the\ environment variable HOME.) If the environment variable\ HOME is not set the platform-specific variant\ of "/" will be used. If you are on a Windows platform the file will be\ named _tkdiff.rc and will have the attribute "hidden". For\ all other platforms the file will be named\ ".tkdiffrc". You may override the name and location of this\ file by setting the environment variable TKDIFFRC to\ whatever filename you wish. You may view, edit, locally apply and even save preferences (to the file just\ described above) from a provided dialog accessible via the\ Edit menu Preferences... item. It is necessary to\ actually Apply any changes before attempting to\ Save them, as saving to the preferences file will\ only save the current setting values, and not\ those that may have been editted, but not yet applied. Should any\ individual setting be deemed unworkable, its prior value will\ most often be reverted AND a popup message produced. Dismiss,\ besides removing the dialog will also attempt to CANCEL any\ edits made after the most recent Apply. You will be asked for\ confirmation to proceed in this case, to give you the opportunity to\ Apply them before losing them completely. There is one small side-effect of Applying the preferences, and that is an unavoidable "re-balancing" of the Grip that is\ used for apportioning horizontal space among the Left and Right windows. Be aware though, that certain preferences, when subsequently\ Applyed, will cause $g(name) to immediately re-invoke "Diff",\ which will reset any UN-SAVED interactive work\ (particularly any merge choices or "Split" CDRs) to their initial states. The following descriptions will, among other things, identify which of them\ can exhibit this behavior; yet the characteristic each has in common\ is that they somehow involve the "interpretation" of the Diff\ results (eg. blank-handling, ignores, etc.). However, as a\ safety net, should an Apply happen to encounter a "reverted"\ setting due to problems and ALSO detect the need to Rediff,\ $g(name) will suspend that need and instead allow you to\ repair the failed settings. Besides a popup message to that\ effect, the Apply button itself will flash RED (briefly) upon\ detecting ANY errors (for which you will have been shown messages).\ Conversely, if applying the settings has been successful, the button\ flash will be GREEN, in addition to any possibly visible\ changes you may observe in the main windows from your new settings. Preferences are organized onscreen into FOUR categories: General, Display,\ Behavior and Appearance. Yet, in the resulting file, they are kept in\ alphabetical order of the preference identifier key. But EACH will have\ the same descriptive labels (on screen, in this Help, or as a comment in\ the file). For the purposes here, they will be presented in their\ onscreen grouping and order. General $pref(diffcmd) This is the command that will be run to generate a diff of the two files.\ Typically this will be "diff"; yet other differencing engines, providing\ other algorithms are possible, given the constraints that it exhibit the\ same output syntax, return code semantics, and to a much lesser degree,\ command line formulation. When this command is run, the names\ of the two files to be diffed will be added as the last two arguments\ on the command line in left-to-right order. If the \"$pref(ignoreblanksopt)\" (described next) is specified\ and enabled, it too will be included in the resulting command. $pref(ignoreblanksopt) Arguments to send with the diff command to tell it how to ignore whitespace.\ If you are using GNU diff, "-b" or "--ignore-space-change" ignores\ changes in the amount of whitespace, while "-w" or\ "--ignore-all-space" ignores all white space. Because of an unfortunate\ interaction with yet another option ("-B" which $g(name)\ itself handles) we currently require the use of the\ short argument names here. If this field is shown disabled, it can be accessed by toggling\ the \"$pref(ignoreblanks)\" option described below. Note that\ when this field is disabled, its value will be ignored,\ although it will still be retained. $pref(tmpdir) The name of a directory for files that are temporarily created while $g(name)\ is running. For most systems, this value is initially obtained from the\ environment variable TMPDIR. As MacOS has been known to fill this\ variable with some outlandish paths, $g(name) initially sets it simply\ to "/tmp" on that platform. You, of course, may choose what you wish. $pref(editor) The name of an external editor program to use when editing a file (ie: when\ you select "Edit" from the popup menu). If this value is empty, a\ simple editor built in to $g(name) will be used, and will be positioned\ such that the current diff is visible. Windows users might want to set\ this to "notepad". Unix users may want to set this to "xterm -e vi" or perhaps "gnuclient". When run, the name of the file to edit will be appended as the last argument\ on the command line. Alternately, if the supplied value contains the\ string "\$file" (without the quotes), it's treated as a complete\ external command line, allowing any additional legal syntax, where the\ following parameters can be used: \$file: the file of the window you invoked upon \$line: the starting line of the current diff For example, in the case of NEdit or Emacs you could use "nc -line \$line \$file" and "emacs +\$line \$file" respectively. Or for VI, perhaps something like "xterm -e vi +:set\\\\ nu +\$line \$file" which opens VI in a separate\ Xterm window, loads the file at the designated CDR line AND causes line\ numbering within VI to be turned "on". $pref(ignoreRegexLnopt) An editable dropdown list of Regular Expressions that are used to identify text\ lines that should be ignored/suppressed (when possible, and activated)\ thereby eliminating them from being displayed/highlighted AS\ real Diff regions. But you must be very cautious when forming\ such Regular Expressions, so as to NOT IDENTIFY a line that might have\ OTHER legitimate differences on it. Initially, the item will display nothing except its dropdown arrow.\ To view the existing list, simply click the dropdown arrow, and scroll\ thru the resulting list. Clicking on an entry of that list,\ is a request to delete it, but you will be asked for\ confirmation first, which you may decline. However, declining conveniently PLACES that entry into the originally\ empty dropdown entry box, where you may then edit it by\ first clicking on it (to remove the selection highlight) and\ then using the keyboard to traverse about the entry (arrows, backspace,\ retyping) until satisfied, whereupon pressing [Return] will\ add it as a new value (not as an edit\ to the previous entry). Note that shifting the current focus\ away via a mouse click elsewhere, or pressing [Tab],\ also counts as a [Return], confirming your edit completion.\ Obviously if this happens prematurely, you only need delete it and\ try again. If instead you simply start typing first, either AFTER a declined\ deletion, or from the initial empty display state, you will directly\ add whatever is typed after pressing [Return]. Nevertheless, confirmation of each "add" or "delete" will be flashed\ momentarily whenever the list is actually modifed (and the entry will\ then be returned to its empty-looking initial state). If the entire item is shown disabled, it can be accessed by\ toggling the \"$pref(ignoreRegexLn)\" option described\ (shortly) below. $pref(filetypes) Another editable dropdown list, consisting this time of file suffixes you may\ wish to use as filters in the various file open and save dialogs\ throughout the tool. Editting procedures are as described immediately\ above, except that the format is that of two "words" separated by white\ space. The first word is used as a label, and if it contains spacing,\ should be enclosed in {braces}. The second is a file-glob\ pattern depicting applicable file extension you wish to see. Thus entries\ like "All *" or "{Text Files} *.txt" or even "{C Files} *.[cChH]" should\ all be self explanatory. For sanitys sake, it is best to keep the\ labels short! $pref(geometry) This defines the default size, in characters, of the two main text\ windows. The format must be WIDTHxHEIGHT. For example, "80x40". However, note that while $g(name) will TRY to honor this request, if it\ would result in the overall tool attempting to display as LARGER than the\ screen size of your monitor, the actual values used may be trimmed back\ to fit. While various realities (this setting, Font size, your Monitor\ resolution) may all affect the initial tool display, once\ completed, you are free to resize the tool as you desire, including\ making it larger than your screen; although doing so may make\ general operations more difficult. $pref(ignoreblanks) If set, then the above "$pref(ignoreblanksopt)" will\ be included whenever a diff is executed. It also permits that option\ to be editted. If unset, that same option will not participate in any\ Diff and is also disabled from being modified. You may toggle this setting simply to gain editting access to the\ "$pref(ignoreblanksopt)", but if you press Apply\ BEFORE toggling BACK to its original value (be that either\ set or unset), it will trigger an\ immediate "Rediff" which WILL DISCARD any\ transitory activity not yet finalized. $pref(autocenter) If set, whenever a new diff region becomes the CDR (for example,\ when pressing the Next or Prev buttons), the\ diff region will be automatically centered on the screen. If unset, no automatic centering will occur. However, the setting\ may also be ignored in the unique situation where\ "autoselection" (described shortly) is also set and the\ display is already being PHYSICALLY scrolled. Stated differently:\ auto-centering will not "fight" the user over who gets to position the\ text window content. $pref(ignoreEmptyLn) If set, then $g(name) will not count, nor highlight, any region\ that is exclusively comprised of empty (or possibly white space filled\ lines if the above \"$pref(ignoreblanksopt)\" is active)\ whenever a diff is executed. This essentially mimics a feature of the\ original Diff program, but is performed entirely within $g(name). If unset, no special significance is attached to blank/empty lines\ and $g(name) will report the regions as Diff reports them. Note if you press Apply AFTER changing this setting (either to\ set or unset), it will trigger an\ immediate "Rediff" which WILL DISCARD\ any transitory activity not yet finalized. Also note that when you choose to ignore empty lines, you are implicitly\ saying that those affected lines will be retained in any\ merged output exactly as they appearred originally in the\ Left-hand text window. Note that for $g(name) to permit the DR to\ be ignored, every line must be classified as such\ regardless of the specific reason (ie. based on being BLANK,\ or as a result of matching any ONE Regular Expression - described above). $pref(autoselect) If set, automatically select the visible diff region nearest to the\ middle of the text window when scrolling. If unset, the current diff region will not change during scrolling. This only takes effect if "$pref(syncscroll)" is set,\ thus can be thought of as a "modifier" for that setting. $pref(ignoreRegexLn) If set, then the above "$pref(ignoreRegexLnopt)" will\ participate whenever a diff is executed. It also permits that option\ to be editted. If unset, that same option will not participate\ in any invoked diff and is also disabled from being modified. You may toggle this setting simply to gain editting access to the\ "$pref(ignoreRegexLnopt)", but if you press Apply\ BEFORE toggling BACK to the original value (be it set\ or unset), it will trigger an immediate\ "Rediff" which WILL DISCARD any\ transitory activity not yet finalized. Conversely, if you set this, but the list of REs is empty at the\ time of the "Apply", this setting will simply revert to unset\ without error. Again, note that when you choose to ignore matched lines, you are implicitly\ saying that those affected lines will be retained in any\ merged output exactly as they appeared originally in the Left\ text window. Also, as before, for $g(name) to permit the DR to\ be ignored, every line must be classified as such\ regardless of the specific reason (ie. based on being BLANK,\ or as a result of matching any ONE expression). $pref(autoSrch) When set, $g(name) will automatically initiate, at any tool startup\ that does NOT provide a FILESPEC, an attempt to\ query a detected, preferred and capable SCM for files that it claims have\ differences. While this capability is always available at startup when at\ least one REV is provided, this setting\ overrides the normal behavior of $g(name) to produce the\ New... Diff dialog, when zero arguments are provided. Note that for most capable SCMs to be detected in this fashion, the\ Current Working Directory (CWD) for\ $g(name) needs to be inside the actual "Working Copy" (WC) set of files\ the particular SCM controls. When the choice is unset, normal dialog behavior is restored.\ This setting is mostly a convenience for users that find themselves\ actively persuing merge resolutions in a SCM-controlled environment on a\ day-to-day basis. $pref(syncscroll) If set, scrolling either text window will result in both windows\ scrolling. If unset, the windows will scroll independent of each other. Note that this setting has only a limited effect on the Merge\ Preview window contents, in that changes of the CDR will\ "jump" scroll, but direct interactive scrolling will not (see the\ Help topic "On GUI" for more details). $pref(scmPrefer) This setting is actually a pair of values, describing which SCM you prefer to\ utilize for EACH of the two possible sides of the comparison. Initially\ both values default to "Auto" which produces the classical $g(name)\ behavior of the "first-detected" SCM possible (based on an internal\ precedence list of known SCM systems). By choosing a specific\ SCM system, you are effectively overriding that internal list\ provided the chosen value is still detectable.\ If not, then the behavior reverts to the classical norm whenever that\ side requires the use of an SCM. There is also a possible value of 'None', if you believe that\ NO SCM should be involved for that side, but be aware that\ such a setting may interfere with the ability to query an otherwise\ capable SCM from providing candidates to be compared. $g(name) will try\ to inform you should this seem to occur, although there are other\ reasons, besides this, for that possibility. Note however, that because\ of subtle differences between the two ways of starting the tool: the\ command line or the dialog, 'None' is generally ignored for\ command line uses, while it will behave as a preferred value\ on the dialog, until the dialog is actually accepted. $pref(predomMrg) This setting decides, for those cases where no specific reason (such as an\ implied choice from a 3way ancestor diff) exists, which of the two sides\ Left or Right, should be initialized\ as contributing its portion of the changed lines to the eventual merge\ result. Determining how best to toggle this setting involves not only the order\ of files as provided initially, but also on the specific goals\ envisioned by the user for the merge as a whole. For example, if\ back-porting some specific capability, it might be best to select the\ side of the older file, and then only interactively merge the needed\ individual regions from the newer one. This option most often comes into play when a Diff is invoked,\ although it will also apply when Split or Combine\ is used and there was no other reason to choose a side,\ as every region must ultimately posess SOME setting prior to\ being displayed. Display $pref(toolbarIcons) If set, the toolbar buttons will use icons instead of text labels. If unset, the toolbar buttons will use text labels instead of icons. Be advised that the toolbar can be a crowded place, and that generally speaking\ the icon-style buttons take less space, and provide Tooltip popup\ descriptions in the event you can't recall what any individual graphic\ means. $pref(fancyButtons) If set, toolbar buttons will mimic the visual behavior of typical\ Microsoft Windows applications. Buttons will initially be flat until the\ cursor moves over them, at which time they will be raised. If unset, toolbar buttons will always appear raised. This feature is not supported in MacOSX. $pref(showln) If set, line numbers are displayed alongside each line of each file. If unset, no line numbers will appear. $pref(tagln) If set, line numbers are highlighted with the options defined in\ the Appearance section of the preferences. If unset, line numbers won\'t be highlighted. $pref(showcbs) If set, change bars are displayed alongside each diff region line\ of each file. If unset, no change bars will appear. The exact form of such change-bars are controlled by further preferences,\ described next. $pref(tagcbs) If set, change indicators will be highlighted. The highlighting\ itself is the subject of yet another preference\ "$pref(colorcbs)" described shortly. If unset change indicators are simply displayed as encoded textual\ markers: a "+" for lines that exist in only one file; a "-" for lines\ that are missing from only one file, and "!" for lines that differ\ between the two files. $pref(showmap) If set, a colorized, graphical "diff map" will be displayed between\ the two files, showing regions that have changed. By default, Red is\ used to show deleted lines, Green for added lines, Blue for changed\ lines, and Yellow for overlapping lines during a 3-way merge. Note that\ any of these colors are themselves "preferences" and thus, changeable\ (See entries under section Appearance below). If unset, the diff map will not be shown. $pref(colorcbs) If set the change bars will appear as solid colored bars\ that match the colors used in the diff map. If unset, IN ADDITION to just the color bars, the change bars will\ display a "+" for lines that exist in only one file, a "-" for lines\ that are missing from only one file, and "!" for lines that differ\ between the two files. Due to color-on-color layering, the "!" markers\ may visually disappear in this situation from BOTH using the same color. $pref(tagtext) If set, the file contents will be highlighted with the options\ defined in the Appearance section of the preferences. If unset, the file contents won't be highlighted. Note - failure to generally highlight the text may make some functions of $g(name) problematic, but the choice remains yours. $pref(showinline1) If set, show inline diffs in the main window. This is useful to\ see what the actual diffs are within a large diff region. If unset, the inline diffs are neither computed nor shown. This\ is the simpler method, where byte-by-byte comparisons\ are used. However, this inline diff never honors\ any "$pref(ignoreblanksopt)" value, regardless of that\ option being enabled. $pref(showinline2) If set, show inline diffs in the main window. This is useful to see\ what the actual diffs are within a large diff region. If unset, the inline diffs are neither computed nor shown. This\ approach is more complex, but should give more pleasing\ results for source code and written text files. This is the\ Ratcliff/Obershelp pattern matching algorithm which recursively\ finds the largest common substring, and recursively repeats on the left\ and right remainders. However, this inline diff never honors\ any "$pref(ignoreblanksopt)" value, regardless of that\ option being enabled. $pref(showlineview) If set, display the window near the bottom of the display that\ shows the "current" line from each file, one above the other.\ Clicking on any specific line, or manuevering the text 'insert' cursor\ via the keyboard, in either text window selects which line to display.\ This window is most useful to do a visual byte-by-byte comparison of a\ line that has changed; by default, the display begins with text rendered\ the same as in the main display, with mismatched bytes marked with\ underlines, and a blue background and white foreground, but other\ approaches include configuring with a "constant width" font\ (via $pref(bytetag)) such as "Courier" to more easily spot\ the differences, and/or perhaps a different foreground color. If unset, the window will not be shown. Behavior It is said that people who spend large blocks of time using any given tool\ often become what is termed "power users". As such they become so\ familiar with the sequence of operations, that they prefer to keep\ their hands on the keyboard and NOT the mouse. Nearly all operations\ in a tool have some keyboard equivalent to allow them to be invoked.\ These are called "keyboard accelerators", or simply, hotkeys.\ As of $g(name) V5.1, it is now possible for the user to specify what\ specific keys are preferred for tool functions previously provided\ almost exclusively via "menus" or "buttons". Those other\ mechanisms continue to exist, but $g(name) now allows the "power users"\ to select their own. Each of the following items operates in exactly the same fashion. Only\ the task each performs is unique. Thus the following describes how to\ review and/or change each key-combination for any of these features. Simply hovering the mouse over any given item will cause the item\ display to switch from its brief "task description" to showing the\ individual key-combination that will invoke said function. To actually change that value, clicking the specific item will\ "arm" it to accept the\ very next keyboard interaction to be made. Be advised:\ despite an item holding the current focus highlight, you may NOT\ use spacebar (or any other platform-specific\ keyboard-click equivalent) to perform that click. To alert\ you that this very critical step has been primed, the background of the\ item will be changed to the "inform" (ie. the ToolTip) color. At this\ juncture, if you move the mouse to LEAVE the item, the edit will be\ cancelled. If instead you actually press some key-combination\ (for example: Shift Z), that combination will\ temporarily replace whatever combination was previously\ present. It will ALSO visually SHIFT that displayed value from being\ centered to being "left-justified" still with the "inform"\ background color. You are now in a "textual-modify" phase, where it may be advantageous to\ adjust the value to something either more, or less, specific (ie. adding\ or removing various "modifier" keys, such as Shift, or Control, Numlock\ or the mostly useless descriptor "Key" - which must never be\ removed if the remaining value is a digit). The mouse is no\ longer required to stay within the item bounds at this time, but will\ only function in a restricted manner. You may use it to set the\ insert-cursor position for performing edits (just as any normal entry\ field). It is ALSO permitted to access certain Dialog buttons\ (specifically the Apply or Dismiss ones), which\ will finalize the edit in a manner consistent with each,\ as a shortcut. Beyond that shortcut, only one of two choices remain; either you press\ the "Escape" key (to cancel the entire edit sequence),\ or press "Return" to confirm that the sequence is as you intended it.\ Either finalizes the hotkey definition process, removes the special\ background "inform" color, and returns you to normal operation. As a convenience to the "power users", pressing [Tab] (or [Shift-Tab])\ will be treated as an implicit "Return". Clicking either of the two\ Dialog buttons (via mouse OR keyboard actions) mentioned earlier will\ complete the editting phase with the appropriate "cancel" or "accept"\ action (eg. Dismiss as a "cancel") while also immediately\ performing their normal task. Note that while MOST keys on a keyboard CAN be specified, including\ keypads and function keys, SOME may have been usurped by the Operating\ System or Window Manager and will never even be delivered to $g(name).\ Many OTHERS could have some generally defined meaning with Tcl/Tk;\ particularly within the various textual widgets. The good news there is\ that because nearly all of the $g(name) widgets operate in a\ "display only" mode within the main tool windows (where these hotkeys\ exist), there is a low chance of cross connecting your choice of hotkeys\ with those of the widgets themselves. Just be aware that anything\ YOU choose that has not been incapacitated (by virtue of that\ "display only" widget status) would operate\ in addition to (and after) anything Tcl/Tk might use the same\ keys for, unless the Tcl/Tk definition chooses to block further actions. Our recommendation, is to keep it simple and preferrably unique. Most\ typing keys would be available as there are few places in $g(name) where\ typing is possible. If you wish to create a "mode-based" family of\ hotkeys (eg. lots of people like the idea of using the "arrow" keys in\ place of the default "merge choice" keys), then perhaps pairing them\ with the use of "NumLock" would allow that use when desired, without\ sacrificing the normal arrow usage (such as moving the text insert\ cursor about), NOR requiring a second key (Shift, Control, etc) to be\ simultaneously held down. We specifically require the use of the mouse in the "arming" operation,\ to limit mis-struck keys, at in-opportune times. Safety for the less-than\ "power-user" community overrides the minor inconvenience to the real\ ones among you, who will likely use this capability once and\ then, never adjust it again! $pref(navFrst) This hotkey is defaulted to "f" $pref(navLast) This hotkey is defaulted to "l" $pref(navNext) This hotkey is defaulted to "n" $pref(navPrev) This hotkey is defaulted to "p" $pref(navCntr) This hotkey is defaulted to "c" $pref(mrgLeft) This hotkey is defaulted to "Key-1" $pref(mrgRght) This hotkey is defaulted to "Key-2" $pref(mrgLtoR) This hotkey is defaulted to "Key-3" $pref(mrgRtoL) This hotkey is defaulted to "Key-4" $pref(genEdit) This hotkey is defaulted to "e" $pref(genFind) This hotkey is defaulted to "Control-f" $pref(genNxfile) This hotkey is defaulted to "Control-[" $pref(genPvfile) This hotkey is defaulted to "Control-]" $pref(genRecalc) This hotkey is defaulted to "Control-r" $pref(genXit) This hotkey is defaulted to "Control-q" The final two settings are a deviation from historical $g(name) (which never\ required the Control-Key modifier) as it was considered safer to require\ TWO fingers on the keyboard before wiping out all in-progress transitory\ work, for which there is no recovery, beyond reconstruction. One other small point should be made about ALL of the Behavior settings -\ technically, each is platform dependent! Each platform has\ unique names, particularly for some of the "modifier" keys. $g(name)\ therefore will prefix the specific windowing system ID to each of the\ preference identifiers when storing and retrieving the values to the\ preferences file. While this was not originally intended to be a\ "feature", it does exhibit the unusual ability for a single preference\ file to be directly USABLE on multiple platforms, WITHOUT data collisions. It also means that each platform will require its OWN specialization\ work, as regards which specific keys are being configured to do what. Appearance As the majority of the $g(name) content is textual, the presentation of such\ information is at the heart of most of the tools features. Controlling\ and tuning that presentation is therefore key to obtaining the best\ experience in using it, but only when it matches the users expectations\ of proper degrees of emphasis - which is highly subjective. Tcl/Tk has\ a remarkably rich set of attributes that can be applied, and even\ layered atop each other. While $g(name) makes use of many of these\ attributes itself, it still makes sense to allow the user to make many\ of these adjustments on their own. While $g(name) must necessarily "OWN" the organization of the various\ display layers, to maintain functionality, describing such layering is\ important when trying to determine what "other" attributes may help the\ user obtain their most useful presentation. Just be aware that $g(name)\ utilizes several of these attributes itself, and might not\ operate correctly should some be arbitrarily introduced. As a general\ rule, colors, fonts and sizes are likely candidates for customization;\ with the syntax rules for their specification dictated by Tcl/Tk. $pref(textopt) This is a list of Tk text widget options that are applied to each of the two\ text windows in the main display, and the Merge Preview. If you have Tk\ installed on your machine (and you should) these will be documented in\ the "Text.n" manual page. These settings constitute the "base" layer of\ attributes which will be seen, unless some "higher layer" of attributes\ is designated as being ABOVE them. The remaining settings will describe\ when such a "change in layer" takes place. $pref(difftag) This is a list of Tk text widget tag options that are applied to all diff\ regions. These options have a higher priority than those for just plain\ text. Use this option to make diff regions stand out from regular text. $pref(deltag) This is a list of Tk text widget tag options that are applied to regions that\ have been deleted. These options have a higher priority than those for\ all diff regions. $pref(instag) This is a list of Tk text widget tag options that are applied to regions that\ have been inserted. These options have a higher priority than those for\ all diff regions. $pref(chgtag) This is a list of Tk text widget tag options that are applied to regions that\ have been changed. These options have a higher priority than those for\ all diff regions. $pref(currtag) This is a list of Tk text widget tag options that are applied to the current\ diff region. So, for example, if you set the forground for all diff\ regions to be black and set the foreground for this option to be blue,\ these current diff region settings (eg. foreground color) will be used.\ These tags have a higher priority than those for all diff regions, AND\ a higher priority than the change, inserted and deleted diff regions,\ but ONLY in the LEFT text window. In the RIGHT text window, these\ settings fall BELOW the individual change-category ones described. $pref(inlinetag) This is a list of Tk text widget tag options that are applied to differences\ within lines in a diff region. These tags have a higher priority than\ those for all diff regions, and a higher priority than the change,\ inserted and deleted diff regions, AND the current region. $pref(bytetag) This is a list of Tk text widget tag options that are applied to individual\ differing characters in the line view. These options do not\ affect the main text displays. Note that if a font specification is also\ included, that font will be used for ALL the characters, not\ just the differing ones. If you remove all settings, text will appear as\ it does in the main displays, with NO difference highlighting\ at all. Think of it as a completely independent "layering" stack. $pref(tabstops) This defines the number of characters for each tabstop in the main display\ windows. Be aware that with the ability to specify fonts, not only of\ the basic text display layer, but of layered individual character ranges\ (as happens with "inline-diff" highlighting), the mere presence of a\ [Tab] will not generally cause pieces of text to "align" as might\ ordinarily be expected. This problem gets worse when considering the use\ of "so called" proportional fonts. Nevertheless, the default is 8. The remaining Appearance items are all formerly internal color settings that have now been made\ accessible for customization. Each takes the form of a button, when\ hovered over by the mouse, displays the current color each uses. Pressing that button will popup a color chooser dialog to make\ adjustments for the items (described) that the setting covers. $pref(inform) is used primarily in the production of popup ToolTip window backgrounds\ to help draw your attention to it (before it disappears). Its other use\ plays a role in the editting sequence of a global hotkey definition to\ again draw your attention to the "sensitive state" where just\ touching practically ANY key on the keyboard will result in\ advancing the definition procedure. The default is "goldenrod". $pref(adjcdr) is used exclusively by the Split or Combine\ features to highlight (in the text windows) the bounds of the CDR as\ it is being adjusted. The default is "magenta". $pref(mapins) is used by the "Diff Map" as well as Split/Combine text\ window feedback and potentially the highlighting of Line numbers or\ Changebars (if requested), to indicate something being "added". The\ default is "Pale Green". $pref(mapchg) is used by the "Diff Map" as well as Split/Combine text\ window feedback and potentially the highlighting of Line numbers or\ Changebars (if requested), to indicate something being "changed". The\ default is "Dodger Blue". $pref(mapdel) is used by the "Diff Map" as well as Split/Combine text\ window feedback and potentially the highlighting of Line numbers or\ Changebars (if requested), to indicate something being "deleted". The\ default is "Tomato". $pref(mapolp) is used by the "Diff Map" as well as Split/Combine text\ window feedback and potentially the highlighting of Line numbers or\ Changebars (if requested), to indicate a COLLISION between diff\ regions during a 3way diff. Classically this color had actually\ been hardcoded, let alone defaulted to "yellow". Custom Settings There is an additional setting built-in to the Preferences file called\ customCode (together with a comment about not using it) that\ nevertheless has some simple uses. The big advantage is that, like each\ other setting described above, the contents of this setting IS\ retained automatically when modified by the $g(name) Preferences Dialog. However, it can only be set or modified externally\ via a text editor. Still, occasionally there have been customizations of\ the GUI that many users found helpful that are often difficult (if not\ impossible) to specify correctly using other means. Although there are\ fewer at the moment (per the newer 'color' buttons described above), we\ offer up the following (still valid) possibilit(y/ies) as suggestions: 1. Highlighting the current Merge Choice (when in Icon mode) - This item, typically required the use of XResources in the past to do\ correctly, but the following is much simpler: set w(selcolor) orange makes it easier to see which of the four icons is presently "selected", as\ the default is generally only a greyed background shading of the\ unselected state. Note that the command "set" and name "w(selcolor)"\ must be exactly as shown (using parenthesis). CAVEAT: Doing more than this requires intimate knowledge of the internal\ code, and, as such, could be subject to future elimination or even\ promotion to a full fledged REAL 'Preference' setting. But for now,\ it works. Moreover, the admonishment to not misuse this facility still\ applies, as it is exceedingly easy to disrupt normal program operation. } # since we have embedded references to the preference labels in # the text, we need to perform substitutions. Because of this, if # you edit the above text, be sure to properly escape any dollar # signs that are not meant to be treated as a variable reference do-text-info .help-prefs $title [subst -nocommands $text] } ###################################################################### # # text formatting routines derived from Klondike # Reproduced here with permission from their author. # # Copyright (C) 1993,1994 by John Heidemann # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # 1. Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # 3. The name of John Heidemann may not be used to endorse or promote products # derived from this software without specific prior written permission. # # THIS SOFTWARE IS PROVIDED BY JOHN HEIDEMANN ``AS IS'' AND # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL JOHN HEIDEMANN BE LIABLE # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF # SUCH DAMAGE. # ###################################################################### proc put-text {tw txt} { $tw configure -font {Fixed 12} $tw configure -font -*-Times-Medium-R-Normal-*-14-* $tw tag configure bld -font -*-Times-Bold-R-Normal-*-14-* $tw tag configure cmp -font -*-Courier-Medium-R-Normal-*-12-* $tw tag configure hdr -font -*-Helvetica-Bold-R-Normal-*-16-* -underline 1 $tw tag configure itl -font -*-Times-Medium-I-Normal-*-14-* $tw tag configure ttl -font -*-Helvetica-Bold-R-Normal-*-18-* #$tw tag configure h3 -font -*-Helvetica-Bold-R-Normal-*-14-* $tw tag configure btn -foreground white -background grey $tw mark set insert 0.0 set t $txt while {[regexp -indices {<([^@>]*)>} $t match inds] == 1} { set start [lindex $inds 0] set end [lindex $inds 1] set keyword [string range $t $start $end] set oldend [$tw index end] $tw insert end [string range $t 0 [expr {$start - 2}]] purge-all-tags $tw $oldend insert if {[string range $keyword 0 0] == "/"} { set keyword [string trimleft $keyword "/"] if {[info exists tags($keyword)] == 0} { error "end tag $keyword without beginning" } $tw tag add $keyword $tags($keyword) insert unset tags($keyword) } else { if {[info exists tags($keyword)] == 1} { error "nesting of begin tag $keyword" } set tags($keyword) [$tw index insert] } set t [string range $t [expr {$end + 2}] end] } set oldend [$tw index end] $tw insert end $t purge-all-tags $tw $oldend insert } proc purge-all-tags {w start end} { foreach tag [$w tag names $start] { $w tag remove $tag $start $end } } ############################################################################### # Open one of the diffed files in an editor if possible # Ordinarily depends on g(activeWindow) to designate which file # However, when invoked as an accelerator, TRIES to WORK if the keypress # happened when the mouse was OVER a reasonable choice of window, otherwise # look if one is holding the current focus as a fallback. # Beyond that - we can either blindly USE the 'presently active' one -or- BAIL ############################################################################### proc do-edit { {X {}} {Y {}} } { global g w opts finfo # IF coordinates were provided, we will TRY and PICK a Window to be # TARGETTED as 'active' and then proceed accordingly. if {$X!={} && $Y!={}} { # Attempt to assign g(activeWindow) reasonably foreach win [list [winfo containing $X $Y] [focus] {}] { foreach side {Left Right} { foreach item {Text Info HSB Label} { if {$win == $w($side$item)} { set g(activeWindow) $w(${side}Text) break } } } } #Dbg "Deriving Edit target from $win" # Jump Ball: Flat-out IGNORE the attempt and BAIL : ( ) # - OR - : Use WHATEVER g(activeWindow) already IS : (X) # if {$win=={}} { return } } # Locate the correct filename set ndx [expr {$finfo(fCurpair) * 2}] if {$g(activeWindow) == $w(LeftText)} {incr ndx -1} if {![info exists finfo(tmp,$ndx)]} { # Got the file - GET the line number set file "$finfo(pth,$ndx)" if {$g(count)} { lassign $g(scrInf,$g(currdiff)) line na na O(1) na na O(0) incr line -$O([expr {int($ndx & 1)}]) } else {set line 1} ;# have to pick something if no CDR exists if {[string length [string trim $opts(editor)]] == 0} { simpleEd open "$file" $line } elseif {[regexp "\\\$file" "$opts(editor)"] == 1} { eval set cmdline \"$opts(editor) &\" Dbg "exec $cmdline" eval exec $cmdline } else { Dbg "exec $opts(editor) \"{$file}\" &" eval exec $opts(editor) "{$file}" & } } else { popmsg "This file is not editable" warning "Dis-allowed" } } ############################################################################### # Mac platform-specific display stuff # Note: The 'Dbg' used to be a DBoxProc setting (which is/was ALSO Modal) # When we added $modal to be able to CHOOSE, we had to DROP its use # (which was FINE as it also slipped into "no-longer-recognized") # SO - we either tell Aqua about MODAL windows or we tell it nothing - # Tclers Wiki reference page "Aqua Toplevels" has broken refs or we would # have tried to pick an explicit NON-modal style keyword (if there is one) ############################################################################### proc setAquaDialogStyle {toplev modal {err {}}} { if { !$modal || [catch {tk::unsupported::MacWindowStyle style $toplev moveableModal} err]} { Dbg "if modal($modal) then MacWindowStyle moveableModal failed? {$err}" } } ########################################################################## # A simple editor, from Bryan Oakley. # 22Jun2018 mpm: now accepts (opt.) line number to display (dflt = 1) # 04Aug2018 mpm: additional keywords/parsing added for open subcmd # mpm: now provides line numbering (in adjoining subwindow) ########################################################################## proc simpleEd {command args} { global textfont switch -- $command { open { # Ingest required args (and establish default options): # filename if {[set argn [llength $args]]} { set filename [lindex $args [set count 0]] set line 1 set title "$filename - Simple Editor" set FG {} set BG {} } {error "simpleEd open ?filename?: reqd arg missing"} # ... then see if others were provided (in any order) # [Lnum] ['fg' color] ['bg' color] ['title' xxxx] ['ro'] while {[incr count] < $argn} { switch -glob [set arg [lindex $args $count]] { "\[0-9]" { set line $arg } "f*" { lappend FG -fg [lindex $args [incr count]] } "b*" { lappend BG -bg [lindex $args [incr count]] } "t*" { set title [lindex $args [incr count]] } "ro" { set RO [list configure -state disabled] } } } set w .editor set count 0 while {[winfo exists ${w}$count]} { incr count 1 } set w ${w}$count toplevel $w -borderwidth 2 -relief sunken wm title $w $title wm group $w . menu $w.menubar $w configure -menu $w.menubar $w.menubar add cascade -label "File" -menu $w.menubar.fileMenu menu $w.menubar.fileMenu if {![info exists RO]} { $w.menubar.fileMenu add command -label "Save" \ -underline 1 -command [list simpleEd save $filename $w] $w.menubar.fileMenu add command -label "Save As..." \ -underline 1 -command [list simpleEd saveAs $filename $w] $w.menubar.fileMenu add separator } $w.menubar.fileMenu add command -label "Exit" -underline 1 \ -command [list simpleEd exit $w] if {![info exists RO]} { $w.menubar add cascade -label "Edit" -menu $w.menubar.editMenu menu $w.menubar.editMenu $w.menubar.editMenu add command -label "Cut" -command \ [list event generate $w.text <>] $w.menubar.editMenu add command -label "Copy" -command \ [list event generate $w.text <>] $w.menubar.editMenu add command -label "Paste" -command \ [list event generate $w.text <>] } text $w.text -wrap none -xscrollcommand [list $w.hsb set] \ -borderwidth 0 \ -font $textfont {*}$FG {*}$BG scrollbar $w.hsb -orient horizontal -command [list $w.text xview] # Derive needed info to fabricate/utilize a line numbering canvas set Aft [font metrics $textfont -ascent] ;# Ascent of font set Dw [font measure $textfont "8"] ;# Digit width set Fg [$w.text cget -fg] ;# Same foreground & background canvas $w.cnvs -highlightthickness 0 -bg [$w.text cget -bg] grid $w.cnvs -row 0 -column 0 -sticky nsew grid $w.text -row 0 -column 1 -sticky nsew grid $w.hsb -row 1 -column 1 -sticky ew grid columnconfigure $w 0 -weight 0 grid columnconfigure $w 1 -weight 1 grid columnconfigure $w 2 -weight 0 grid rowconfigure $w 0 -weight 1 grid rowconfigure $w 1 -weight 0 set fd [open $filename] $w.text insert 1.0 [read $fd] close $fd set lenDigits [string length [$w.text index end]] $w.cnvs configure -width [set X [expr {int($lenDigits-2)*$Dw+3}]] # N.B> tracing on the Vert-Scrlbar trips on window resizes too $w.text see $line.0 ;# N.B> done AFTER the trace setup to tickle it if {[info exists RO]} {$w.text {*}$RO } } save { set filename [lindex $args 0] set w [lindex $args 1] set fd [open $filename w] puts $fd [$w.text get 1.0 "end-1c"] close $fd } saveAs { set filename [lindex $args 0] set w [lindex $args 1] set filename [tk_getSaveFile -filetypes $opts(filetypes) \ -initialfile [file tail $filename] \ -initialdir [file dirname $filename]] if {$filename != ""} { simpleEd save $filename $w } } exit { set w [lindex $args 0] destroy $w } } } # end of simpleEd # Copyright (c) 1998-2003, Bryan Oakley # All Rights Reserved # # Bryan Oakley # oakley@bardo.clearlight.com # # combobox v2.3 August 16, 2003 # # MODIFIED (for TkDiff) # 31Jul2018 mpm: (<-tagged) added support for 'list itemconfigure' subcommand # 25Oct2020 mpm: (<-tagged) added hack for multiple-monitor issue (TK bug?) # # a combobox / dropdown listbox (pick your favorite name) widget # written in pure tcl # # this code is freely distributable without restriction, but is # provided as-is with no warranty expressed or implied. # # thanks to the following people who provided beta test support or # patches to the code (in no particular order): # # Scott Beasley Alexandre Ferrieux Todd Helfter # Matt Gushee Laurent Duperval John Jackson # Fred Rapp Christopher Nelson # Eric Galluzzo Jean-Francois Moine Oliver Bienert # # A special thanks to Martin M. Hunt who provided several good ideas, # and always with a patch to implement them. Jean-Francois Moine, # Todd Helfter and John Jackson were also kind enough to send in some # code patches. # # ... and many others over the years. package require Tk 8.0 package provide combobox 2.3 namespace eval ::combobox { # this is the public interface namespace export combobox # these contain references to available options variable widgetOptions # these contain references to available commands and subcommands variable widgetCommands variable scanCommands variable listCommands } # ::combobox::combobox -- # # This is the command that gets exported. It creates a new # combobox widget. # # Arguments: # # w path of new widget to create # args additional option/value pairs (eg: -background white, etc.) # # Results: # # It creates the widget and sets up all of the default bindings # # Returns: # # The name of the newly created widget proc ::combobox::combobox {w args} { variable widgetOptions variable widgetCommands variable scanCommands variable listCommands # perform a one time initialization if {![info exists widgetOptions]} { Init } # build it... eval Build $w $args # set some bindings... SetBindings $w # and we are done! return $w } # ::combobox::Init -- # # Initialize the namespace variables. This should only be called # once, immediately prior to creating the first instance of the # widget # # Arguments: # # none # # Results: # # All state variables are set to their default values; all of # the option database entries will exist. # # Returns: # # empty string proc ::combobox::Init {} { variable widgetOptions variable widgetCommands variable scanCommands variable listCommands variable defaultEntryCursor array set widgetOptions [list \ -background {background Background} \ -bd -borderwidth \ -bg -background \ -borderwidth {borderWidth BorderWidth} \ -buttonbackground {buttonBackground Background} \ -command {command Command} \ -commandstate {commandState State} \ -cursor {cursor Cursor} \ -disabledbackground {disabledBackground DisabledBackground} \ -disabledforeground {disabledForeground DisabledForeground} \ -dropdownwidth {dropdownWidth DropdownWidth} \ -editable {editable Editable} \ -elementborderwidth {elementBorderWidth BorderWidth} \ -fg -foreground \ -font {font Font} \ -foreground {foreground Foreground} \ -height {height Height} \ -highlightbackground {highlightBackground HighlightBackground} \ -highlightcolor {highlightColor HighlightColor} \ -highlightthickness {highlightThickness HighlightThickness} \ -image {image Image} \ -listvar {listVariable Variable} \ -maxheight {maxHeight Height} \ -opencommand {opencommand Command} \ -relief {relief Relief} \ -selectbackground {selectBackground Foreground} \ -selectborderwidth {selectBorderWidth BorderWidth} \ -selectforeground {selectForeground Background} \ -state {state State} \ -takefocus {takeFocus TakeFocus} \ -textvariable {textVariable Variable} \ -value {value Value} \ -width {width Width} \ -xscrollcommand {xScrollCommand ScrollCommand} \ ] set widgetCommands [list \ bbox cget configure curselection \ delete get icursor index \ insert list scan selection \ xview select toggle open \ close subwidget \ ] set listCommands [list \ delete get \ index insert itemconfigure size \ ] ;# mpm - added itemconfigure set scanCommands [list mark dragto] # why check for the Tk package? This lets us be sourced into # an interpreter that doesn't have Tk loaded, such as the slave # interpreter used by pkg_mkIndex. In theory it should have no # side effects when run if {[lsearch -exact [package names] "Tk"] != -1} { ################################################################## #- this initializes the option database. Kinda gross, but it works #- (I think). ################################################################## # the image used for the button... if {$::tcl_platform(platform) == "windows"} { image create bitmap ::combobox::bimage -data { #define down_arrow_width 12 #define down_arrow_height 12 static char down_arrow_bits[] = { 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00, 0xfc,0xf1,0xf8,0xf0,0x70,0xf0,0x20,0xf0, 0x00,0x00,0x00,0x00,0x00,0x00,0x00,0x00; } } } else { image create bitmap ::combobox::bimage -data { #define down_arrow_width 15 #define down_arrow_height 15 static char down_arrow_bits[] = { 0x00,0x80,0x00,0x80,0x00,0x80,0x00,0x80, 0x00,0x80,0xf8,0x8f,0xf0,0x87,0xe0,0x83, 0xc0,0x81,0x80,0x80,0x00,0x80,0x00,0x80, 0x00,0x80,0x00,0x80,0x00,0x80 } } } # compute a widget name we can use to create a temporary widget set tmpWidget ".__tmp__" set count 0 while {[winfo exists $tmpWidget] == 1} { set tmpWidget ".__tmp__$count" incr count } # get the scrollbar width. Because we try to be clever and draw our # own button instead of using a tk widget, we need to know what size # button to create. This little hack tells us the width of a scroll # bar. # # NB: we need to be sure and pick a window that doesn't already # exist... scrollbar $tmpWidget set sb_width [winfo reqwidth $tmpWidget] set bbg [$tmpWidget cget -background] destroy $tmpWidget # steal options from the entry widget # we want darn near all options, so we'll go ahead and do # them all. No harm done in adding the one or two that we # don't use. entry $tmpWidget foreach foo [$tmpWidget configure] { # the cursor option is special, so we'll save it in # a special way if {[lindex $foo 0] == "-cursor"} { set defaultEntryCursor [lindex $foo 4] } if {[llength $foo] == 5} { set option [lindex $foo 1] set value [lindex $foo 4] option add *Combobox.$option $value widgetDefault # these options also apply to the dropdown listbox if {[string compare $option "foreground"] == 0 \ || [string compare $option "background"] == 0 \ || [string compare $option "font"] == 0} { option add *Combobox*ComboboxListbox.$option $value \ widgetDefault } } } destroy $tmpWidget # these are unique to us... option add *Combobox.elementBorderWidth 1 widgetDefault option add *Combobox.buttonBackground $bbg widgetDefault option add *Combobox.dropdownWidth {} widgetDefault option add *Combobox.openCommand {} widgetDefault option add *Combobox.cursor {} widgetDefault option add *Combobox.commandState normal widgetDefault option add *Combobox.editable 1 widgetDefault option add *Combobox.maxHeight 10 widgetDefault option add *Combobox.height 0 } # set class bindings SetClassBindings } # ::combobox::SetClassBindings -- # # Sets up the default bindings for the widget class # # this proc exists since it's The Right Thing To Do, but # I haven't had the time to figure out how to do all the # binding stuff on a class level. The main problem is that # the entry widget must have focus for the insertion cursor # to be visible. So, I either have to have the entry widget # have the Combobox bindtag, or do some fancy juggling of # events or some such. What a pain. # # Arguments: # # none # # Returns: # # empty string proc ::combobox::SetClassBindings {} { # make sure we clean up after ourselves... bind Combobox [list ::combobox::DestroyHandler %W] # this will (hopefully) close (and lose the grab on) the # listbox if the user clicks anywhere outside of it. Note # that on Windows, you can click on some other app and # the listbox will still be there, because tcl won't see # that button click set this {[::combobox::convert %W -W]} bind Combobox "$this close" bind Combobox "$this close" # this helps (but doesn't fully solve) focus issues. The general # idea is, whenever the frame gets focus it gets passed on to # the entry widget bind Combobox {::combobox::tkTabToWindow \ [::combobox::convert %W -W].entry} # this closes the listbox if we get hidden bind Combobox {[::combobox::convert %W -W] close} return "" } # ::combobox::SetBindings -- # # here's where we do most of the binding foo. I think there's probably # a few bindings I ought to add that I just haven't thought # about... # # I'm not convinced these are the proper bindings. Ideally all # bindings should be on "Combobox", but because of my juggling of # bindtags I'm not convinced thats what I want to do. But, it all # seems to work, its just not as robust as it could be. # # Arguments: # # w widget pathname # # Returns: # # empty string proc ::combobox::SetBindings {w} { upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options # juggle the bindtags. The basic idea here is to associate the # widget name with the entry widget, so if a user does a bind # on the combobox it will get handled properly since it is # the entry widget that has keyboard focus. bindtags $widgets(entry) \ [concat $widgets(this) [bindtags $widgets(entry)]] bindtags $widgets(button) \ [concat $widgets(this) [bindtags $widgets(button)]] # override the default bindings for tab and shift-tab. The # focus procs take a widget as their only parameter and we # want to make sure the right window gets used (for shift- # tab we want it to appear as if the event was generated # on the frame rather than the entry. bind $widgets(entry) \ "::combobox::tkTabToWindow \[tk_focusNext $widgets(entry)\]; break" bind $widgets(entry) \ "::combobox::tkTabToWindow \[tk_focusPrev $widgets(this)\]; break" # this makes our "button" (which is actually a label) # do the right thing bind $widgets(button) [list $widgets(this) toggle] # this lets the autoscan of the listbox work, even if they # move the cursor over the entry widget. bind $widgets(entry) "break" bind $widgets(listbox) \ "::combobox::Select [list $widgets(this)] \ \[$widgets(listbox) nearest %y\]; break" bind $widgets(listbox) { %W selection clear 0 end %W activate @%x,%y %W selection anchor @%x,%y %W selection set @%x,%y @%x,%y # need to do a yview if the cursor goes off the top # or bottom of the window... (or do we?) } # these events need to be passed from the entry widget # to the listbox, or otherwise need some sort of special # handling. foreach event [list \ <1> \ ] { bind $widgets(entry) $event \ [list ::combobox::HandleEvent $widgets(this) $event] } # like the other events, needs to be passed from # the entry widget to the listbox. However, in this case we # need to add an additional parameter catch { bind $widgets(entry) \ [list ::combobox::HandleEvent $widgets(this) %D] } } # ::combobox::Build -- # # This does all of the work necessary to create the basic # combobox. # # Arguments: # # w widget name # args additional option/value pairs # # Results: # # Creates a new widget with the given name. Also creates a new # namespace patterened after the widget name, as a child namespace # to ::combobox # # Returns: # # the name of the widget proc ::combobox::Build {w args } { variable widgetOptions if {[winfo exists $w]} { error "window name \"$w\" already exists" } # create the namespace for this instance, and define a few # variables namespace eval ::combobox::$w { variable ignoreTrace 0 variable oldFocus {} variable oldGrab {} variable oldValue {} variable options variable this variable widgets set widgets(foo) foo ;# coerce into an array set options(foo) foo ;# coerce into an array unset widgets(foo) unset options(foo) } # import the widgets and options arrays into this proc so # we don't have to use fully qualified names, which is a # pain. upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options # this is our widget -- a frame of class Combobox. Naturally, # it will contain other widgets. We create it here because # we need it in order to set some default options. set widgets(this) [frame $w -class Combobox -takefocus 0] set widgets(entry) [entry $w.entry -takefocus 1] set widgets(button) [label $w.button -takefocus 0] # this defines all of the default options. We get the # values from the option database. Note that if an array # value is a list of length one it is an alias to another # option, so we just ignore it foreach name [array names widgetOptions] { if {[llength $widgetOptions($name)] == 1} continue set optName [lindex $widgetOptions($name) 0] set optClass [lindex $widgetOptions($name) 1] set value [option get $w $optName $optClass] set options($name) $value } # a couple options aren't available in earlier versions of # tcl, so we'll set them to sane values. For that matter, if # they exist but are empty, set them to sane values. if {[string length $options(-disabledforeground)] == 0} { set options(-disabledforeground) $options(-foreground) } if {[string length $options(-disabledbackground)] == 0} { set options(-disabledbackground) $options(-background) } # if -value is set to null, we'll remove it from our # local array. The assumption is, if the user sets it from # the option database, they will set it to something other # than null (since it's impossible to determine the difference # between a null value and no value at all). if {[info exists options(-value)] \ && [string length $options(-value)] == 0} { unset options(-value) } # we will later rename the frame's widget proc to be our # own custom widget proc. We need to keep track of this # new name, so we'll define and store it here... set widgets(frame) ::combobox::${w}::$w # gotta do this sooner or later. Might as well do it now pack $widgets(button) -side right -fill y -expand no pack $widgets(entry) -side left -fill both -expand yes # I should probably do this in a catch, but for now it's # good enough... What it does, obviously, is put all of # the option/values pairs into an array. Make them easier # to handle later on... array set options $args # now, the dropdown list... the same renaming nonsense # must go on here as well... set widgets(dropdown) [toplevel $w.top] set widgets(listbox) [listbox $w.top.list] pack $widgets(listbox) -side left -fill both -expand y # fine tune the widgets based on the options (and a few # arbitrary values...) # NB: we are going to use the frame to handle the relief # of the widget as a whole, so the entry widget will be # flat. This makes the button which drops down the list # to appear "inside" the entry widget. $widgets(button) configure \ -background $options(-buttonbackground) \ -highlightthickness 0 \ -borderwidth $options(-elementborderwidth) \ -relief raised \ -width 14 $widgets(entry) configure \ -borderwidth 0 \ -relief flat \ -highlightthickness 0 $widgets(dropdown) configure \ -borderwidth $options(-elementborderwidth) \ -relief sunken $widgets(listbox) configure \ -selectmode browse \ -background [$widgets(entry) cget -bg] \ -exportselection false \ -borderwidth 0 # trace add variable ::combobox::${w}::entryTextVariable write \ # [list ::combobox::EntryTrace $w] # do some window management foo on the dropdown window wm overrideredirect $widgets(dropdown) 1 wm transient $widgets(dropdown) [winfo toplevel $w] wm group $widgets(dropdown) [winfo parent $w] wm resizable $widgets(dropdown) 0 0 wm withdraw $widgets(dropdown) # this moves the original frame widget proc into our # namespace and gives it a handy name rename ::$w $widgets(frame) # now, create our widget proc. Obviously (?) it goes in # the global namespace. All combobox widgets will actually # share the same widget proc to cut down on the amount of # bloat. proc ::$w {command args} \ "eval ::combobox::WidgetProc $w \$command \$args" # ok, the thing exists... let's do a bit more configuration. if {[catch "::combobox::Configure [list $widgets(this)] [array get options]" error]} { catch {destroy $w} error "internal error: $error" } return "" } # ::combobox::HandleEvent -- # # this proc handles events from the entry widget that we want # handled specially (typically, to allow navigation of the list # even though the focus is in the entry widget) # # Arguments: # # w widget pathname # event a string representing the event (not necessarily an # actual event) # args additional arguments required by particular events proc ::combobox::HandleEvent {w event args} { upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options upvar ::combobox::${w}::oldValue oldValue # for all of these events, if we have a special action we'll # do that and do a "return -code break" to keep additional # bindings from firing. Otherwise we'll let the event fall # on through. switch $event { "" { if {[winfo ismapped $widgets(dropdown)]} { set D [lindex $args 0] # the '120' number in the following expression has # it's genesis in the tk bind manpage, which suggests # that the smallest value of %D for mousewheel events # will be 120. The intent is to scroll one line at a time. $widgets(listbox) yview scroll [expr {-($D/120)}] units } } "" { # if the widget is editable, clear the selection. # this makes it more obvious what will happen if the # user presses (and helps our code know what # to do if the user presses return) if {$options(-editable)} { $widgets(listbox) see 0 $widgets(listbox) selection clear 0 end $widgets(listbox) selection anchor 0 $widgets(listbox) activate 0 } } "" { set oldValue [$widgets(entry) get] } "" { if {![winfo ismapped $widgets(dropdown)]} { # did the value change? set newValue [$widgets(entry) get] if {$oldValue != $newValue} { CallCommand $widgets(this) $newValue } } } "<1>" { set editable [::combobox::GetBoolean $options(-editable)] if {!$editable} { if {[winfo ismapped $widgets(dropdown)]} { $widgets(this) close return -code break; } else { if {$options(-state) != "disabled"} { $widgets(this) open return -code break; } } } } "" { if {$options(-state) != "disabled"} { $widgets(this) toggle return -code break; } } "" { if {[winfo ismapped $widgets(dropdown)]} { ::combobox::Find $widgets(this) 0 return -code break; } else { ::combobox::SetValue $widgets(this) [$widgets(this) get] } } "" { # $widgets(entry) delete 0 end # $widgets(entry) insert 0 $oldValue if {[winfo ismapped $widgets(dropdown)]} { $widgets(this) close return -code break; } } "" { # did the value change? set newValue [$widgets(entry) get] if {$oldValue != $newValue} { CallCommand $widgets(this) $newValue } if {[winfo ismapped $widgets(dropdown)]} { ::combobox::Select $widgets(this) \ [$widgets(listbox) curselection] return -code break; } } "" { $widgets(listbox) yview scroll 1 pages set index [$widgets(listbox) index @0,0] $widgets(listbox) see $index $widgets(listbox) activate $index $widgets(listbox) selection clear 0 end $widgets(listbox) selection anchor $index $widgets(listbox) selection set $index } "" { $widgets(listbox) yview scroll -1 pages set index [$widgets(listbox) index @0,0] $widgets(listbox) activate $index $widgets(listbox) see $index $widgets(listbox) selection clear 0 end $widgets(listbox) selection anchor $index $widgets(listbox) selection set $index } "" { if {[winfo ismapped $widgets(dropdown)]} { ::combobox::tkListboxUpDown $widgets(listbox) 1 return -code break; } else { if {$options(-state) != "disabled"} { $widgets(this) open return -code break; } } } "" { if {[winfo ismapped $widgets(dropdown)]} { ::combobox::tkListboxUpDown $widgets(listbox) -1 return -code break; } else { if {$options(-state) != "disabled"} { $widgets(this) open return -code break; } } } } return "" } # ::combobox::DestroyHandler {w} -- # # Cleans up after a combobox widget is destroyed # # Arguments: # # w widget pathname # # Results: # # The namespace that was created for the widget is deleted, # and the widget proc is removed. proc ::combobox::DestroyHandler {w} { catch { # if the widget actually being destroyed is of class Combobox, # remove the namespace and associated proc. if {[string compare [winfo class $w] "Combobox"] == 0} { # delete the namespace and the proc which represents # our widget namespace delete ::combobox::$w rename $w {} } } return "" } # ::combobox::Find # # finds something in the listbox that matches the pattern in the # entry widget and selects it # # N.B. I'm not convinced this is working the way it ought to. It # works, but is the behavior what is expected? I've also got a gut # feeling that there's a better way to do this, but I'm too lazy to # figure it out... # # Arguments: # # w widget pathname # exact boolean; if true an exact match is desired # # Returns: # # Empty string proc ::combobox::Find {w {exact 0}} { upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options ## *sigh* this logic is rather gross and convoluted. Surely ## there is a more simple, straight-forward way to implement ## all this. As the saying goes, I lack the time to make it ## shorter... # use what is already in the entry widget as a pattern set pattern [$widgets(entry) get] if {[string length $pattern] == 0} { # clear the current selection $widgets(listbox) see 0 $widgets(listbox) selection clear 0 end $widgets(listbox) selection anchor 0 $widgets(listbox) activate 0 return } # we're going to be searching this list... set list [$widgets(listbox) get 0 end] # if we are doing an exact match, try to find, # well, an exact match set exactMatch -1 if {$exact} { set exactMatch [lsearch -exact $list $pattern] } # search for it. We'll try to be clever and not only # search for a match for what they typed, but a match for # something close to what they typed. We'll keep removing one # character at a time from the pattern until we find a match # of some sort. set index -1 while {$index == -1 && [string length $pattern]} { set index [lsearch -glob $list "$pattern*"] if {$index == -1} { regsub {.$} $pattern {} pattern } } # this is the item that most closely matches... set thisItem [lindex $list $index] # did we find a match? If so, do some additional munging... if {$index != -1} { # we need to find the part of the first item that is # unique WRT the second... I know there's probably a # simpler way to do this... set nextIndex [expr {$index + 1}] set nextItem [lindex $list $nextIndex] # we don't really need to do much if the next # item doesn't match our pattern... if {[string match $pattern* $nextItem]} { # ok, the next item matches our pattern, too # now the trick is to find the first character # where they *don't* match... set marker [string length $pattern] while {$marker <= [string length $pattern]} { set a [string index $thisItem $marker] set b [string index $nextItem $marker] if {[string compare $a $b] == 0} { append pattern $a incr marker } else { break } } } else { set marker [string length $pattern] } } else { set marker end set index 0 } # ok, we know the pattern and what part is unique; # update the entry widget and listbox appropriately if {$exact && $exactMatch == -1} { # this means we didn't find an exact match $widgets(listbox) selection clear 0 end $widgets(listbox) see $index } elseif {!$exact} { # this means we found something, but it isn't an exact # match. If we find something that *is* an exact match we # don't need to do the following, since it would merely # be replacing the data in the entry widget with itself set oldstate [$widgets(entry) cget -state] $widgets(entry) configure -state normal $widgets(entry) delete 0 end $widgets(entry) insert end $thisItem $widgets(entry) selection clear $widgets(entry) selection range $marker end $widgets(listbox) activate $index $widgets(listbox) selection clear 0 end $widgets(listbox) selection anchor $index $widgets(listbox) selection set $index $widgets(listbox) see $index $widgets(entry) configure -state $oldstate } } # ::combobox::Select -- # # selects an item from the list and sets the value of the combobox # to that value # # Arguments: # # w widget pathname # index listbox index of item to be selected # # Returns: # # empty string proc ::combobox::Select {w index} { upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options # the catch is because I'm sloppy -- presumably, the only time # an error will be caught is if there is no selection. if {![catch {set data [$widgets(listbox) get [lindex $index 0]]}]} { ::combobox::SetValue $widgets(this) $data $widgets(listbox) selection clear 0 end $widgets(listbox) selection anchor $index $widgets(listbox) selection set $index } $widgets(entry) selection range 0 end $widgets(entry) icursor end $widgets(this) close return "" } # ::combobox::HandleScrollbar -- # # causes the scrollbar of the dropdown list to appear or disappear # based on the contents of the dropdown listbox # # Arguments: # # w widget pathname # action the action to perform on the scrollbar # # Returns: # # an empty string proc ::combobox::HandleScrollbar {w {action "unknown"}} { upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options if {$options(-height) == 0} { set hlimit $options(-maxheight) } else { set hlimit $options(-height) } switch $action { "grow" { if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} { pack forget $widgets(listbox) pack $widgets(listbox) -side left -fill both -expand y } } "shrink" { if {$hlimit > 0 && [$widgets(listbox) size] <= $hlimit} { } } "crop" { # this means the window was cropped and we definitely # need a scrollbar no matter what the user wants pack forget $widgets(listbox) pack $widgets(listbox) -side left -fill both -expand y } default { if {$hlimit > 0 && [$widgets(listbox) size] > $hlimit} { pack forget $widgets(listbox) pack $widgets(listbox) -side left -fill both -expand y } else { } } } return "" } # ::combobox::ComputeGeometry -- # # computes the geometry of the dropdown list based on the size of the # combobox... # # Arguments: # # w widget pathname # # Returns: # # the desired geometry of the listbox proc ::combobox::ComputeGeometry {w} { upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options if {$options(-height) == 0 && $options(-maxheight) != "0"} { # if this is the case, count the items and see if # it exceeds our maxheight. If so, set the listbox # size to maxheight... set nitems [$widgets(listbox) size] if {$nitems > $options(-maxheight)} { # tweak the height of the listbox $widgets(listbox) configure -height $options(-maxheight) } else { # un-tweak the height of the listbox $widgets(listbox) configure -height 0 } update idletasks } # compute height and width of the dropdown list set bd [$widgets(dropdown) cget -borderwidth] set height [expr {[winfo reqheight $widgets(dropdown)] + $bd + $bd}] if {[string length $options(-dropdownwidth)] == 0 || $options(-dropdownwidth) == 0} { set width [winfo width $widgets(this)] } else { set m [font measure [$widgets(listbox) cget -font] "m"] set width [expr {$options(-dropdownwidth) * $m}] } # (Sadly, for Windows users the following measurements won't take into # consideration the height of the taskbar, but don't blame me -- there # isn't any way to detect it or figure out its dimensions. The same is # likely true of any window manager with some magic windows glued to the # top or bottom of the screen) # Figure out where to place it on the screen, trying to take into account # we MAY be running under some virtual window manager # (but lets use REALLY-short varnames, 'cause it gets a little involved) # N.B> ALL width/height values are POSITIVE MAGNITUDES only (not coords) lassign "[winfo vrootx $widgets(this)] [winfo vrooty $widgets(this)] [winfo rootx $widgets(this)] [winfo rooty $widgets(this)] $width $height 0 0 [winfo screenwidth $widgets(this)] [winfo screenheight $widgets(this)]" vx vy x y w h X Y W H ########### mpm #TK-BUG? Detected: Oct2020 TK8.6.3(+) Multiple display-monitor hack ### # While the screen DIMENSIONs *may* be correct, they are UN-TETHERED when # related to anything BUT a "main" display SCREEN...(eg. a 2nd monitor) # (ie. where WxH is NOT anchored at [0,0], be that actually or virtually) # The BUG: there exists NO MEANS of obtaining THAT screens ORIGIN coord! # # So, IFF the widget is OUTSIDE the 0-based screen dimension AT THE OUTSET, # then RESET the X,Y,W,H values to its containing Toplevel before going on if {($y+$vy+$h < $Y) || ($y+$vy+$h > $Y+$H) || ($y+$vy < $Y) || ($y+$vy > $Y+$H)} { set TL [winfo toplevel $widgets(this)] lassign "[winfo rootx $TL] [winfo rooty $TL] [winfo width $TL] [winfo height $TL]" X Y W H } # The x coordinate is simply the rootx of our widget, adjusted for # the virtual window. We won't worry about whether the window will # be offscreen to the left or right -- we want the illusion that it # is part of the entry widget, so if part of the entry widget is off- # screen, so will the list. If you want to change the behavior, # simply change the "if{0}" statement... (AND update this comment!) incr x $vx if {0} { # Keep it inboard of the defined limits (when possible) if {($x + $w) > ($X + $W)} { set x [expr {$X + $W - $w}] } if { $x < $X} { set x $X } } # The y coordinate begins as the rooty plus vrooty offset plus # the height of the static part of the widget plus 1 for a # tiny bit of visual separation... set y_below [expr {$y + $vy + [winfo reqheight $widgets(this)] + 1}] # But check if it will FIT (at its present size)... if {($y_below + $h) >= ($Y + $H)} { # No? OK - Fine. So pop it UP above the entry widget instead. set y_above [expr {$y + $vy - $h - 1}] # But (again) check if it fits THERE (at its present size)... if {$y_above < $Y} { # How annoying!! This means it extended beyond our "screen" # Now we'll try to be REALLY clever and either pop it UP or # DOWN, depending on WHICH way gives us the biggest list, # TRIMMING THE LIST to fit and forcing the use of a scrollbar if {($y+$vy) > ($Y + ($H / 2))} { # we are in the LOWER half of the "screen" -- pop it UP. # Y will be its upper-bound; that parts easy. The HEIGHT # becomes its DISTANCE TO the y coordinate of our widget, # minus a pixel for some visual separation. set h [expr {$y + $vy - $Y - 1}] set y $Y } else { # we are in the UPPER half of the "screen" -- pop it DOWN # while trimming its HEIGHT to the lower boundary set h [expr {$y_below - ($Y + $H)}] set y $y_below } HandleScrollbar $widgets(this) crop } else { set y $y_above } } else { set y $y_below } # FINALLY return the resultant geometry return [format "=%dx%d+%d+%d" $w $h $x $y] } # ::combobox::DoInternalWidgetCommand -- # # perform an internal widget command, then mung any error results # to look like it came from our megawidget. A lot of work just to # give the illusion that our megawidget is an atomic widget # # Arguments: # # w widget pathname # subwidget pathname of the subwidget # command subwidget command to be executed # args arguments to the command # # Returns: # # The result of the subwidget command, or an error proc ::combobox::DoInternalWidgetCommand {w subwidget command args} { upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options set subcommand $command set command [concat $widgets($subwidget) $command $args] if {[catch $command result]} { # replace the subwidget name with the megawidget name regsub $widgets($subwidget) $result $widgets(this) result # replace specific instances of the subwidget command # with our megawidget command switch $subwidget,$subcommand { listbox,index {regsub "index" $result "list index" result} listbox,insert {regsub "insert" $result "list insert" result} listbox,delete {regsub "delete" $result "list delete" result} listbox,get {regsub "get" $result "list get" result} listbox,size {regsub "size" $result "list size" result} listbox,itemconfigure { ;# mpm: added entire switch clause regsub "itemconfigure" $result "list itemconfigure" result} } error $result } else { return $result } } # ::combobox::WidgetProc -- # # This gets uses as the widgetproc for an combobox widget. # Notice where the widget is created and you'll see that the # actual widget proc merely evals this proc with all of the # arguments intact. # # Note that some widget commands are defined "inline" (ie: # within this proc), and some do most of their work in # separate procs. This is merely because sometimes it was # easier to do it one way or the other. # # Arguments: # # w widget pathname # command widget subcommand # args additional arguments; varies with the subcommand # # Results: # # Performs the requested widget command proc ::combobox::WidgetProc {w command args} { upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options upvar ::combobox::${w}::oldFocus oldFocus upvar ::combobox::${w}::oldFocus oldGrab set command [::combobox::Canonize $w command $command] # this is just shorthand notation... set doWidgetCommand \ [list ::combobox::DoInternalWidgetCommand $widgets(this)] if {$command == "list"} { # ok, the next argument is a list command; we'll # rip it from args and append it to command to # create a unique internal command # # NB: because of the sloppy way we are doing this, # we'll also let the user enter our secret command # directly (eg: list-insert, list-delete , etc), but we # won't document that fact (mpm: bugfix - was missing Canonize) set command "list-[::combobox::Canonize \ $w {list command} [lindex $args 0]]" set args [lrange $args 1 end] } set result "" # many of these commands are just synonyms for specific # commands in one of the subwidgets. We'll get them out # of the way first, then do the custom commands. switch $command { bbox - delete - get - icursor - index - insert - scan - selection - xview { set result [eval $doWidgetCommand entry $command $args] } list-get {set result [eval $doWidgetCommand listbox get $args]} list-index {set result [eval $doWidgetCommand listbox index $args]} list-size {set result [eval $doWidgetCommand listbox size $args]} list-itemconfigure { ;# mpm - added entire switch clause set result [eval $doWidgetCommand listbox itemconfigure $args]} select { if {[llength $args] == 1} { set index [lindex $args 0] set result [Select $widgets(this) $index] } else { error "usage: $w select index" } } subwidget { set knownWidgets [list button entry listbox dropdown] if {[llength $args] == 0} { return $knownWidgets } set name [lindex $args 0] if {[lsearch $knownWidgets $name] != -1} { set result $widgets($name) } else { error "unknown subwidget $name" } } curselection { set result [eval $doWidgetCommand listbox curselection] } list-insert { eval $doWidgetCommand listbox insert $args set result [HandleScrollbar $w "grow"] } list-delete { eval $doWidgetCommand listbox delete $args set result [HandleScrollbar $w "shrink"] } toggle { # ignore this command if the widget is disabled... if {$options(-state) == "disabled"} return # pops down the list if it is not, hides it # if it is... if {[winfo ismapped $widgets(dropdown)]} { set result [$widgets(this) close] } else { set result [$widgets(this) open] } } open { # if this is an editable combobox, the focus should # be set to the entry widget if {$options(-editable)} { focus $widgets(entry) $widgets(entry) select range 0 end $widgets(entry) icursor end } # if we are disabled, we won't allow this to happen if {$options(-state) == "disabled"} { return 0 } # if there is a -opencommand, execute it now if {[string length $options(-opencommand)] > 0} { # hmmm... should I do a catch, or just let the normal # error handling handle any errors? For now, the latter... uplevel \#0 $options(-opencommand) } # compute the geometry of the window to pop up, and set # it, and force the window manager to take notice # (even if it is not presently visible). # # this isn't strictly necessary if the window is already # mapped, but we'll go ahead and set the geometry here # since its harmless and *may* actually reset the geometry # to something better in some weird case. set geometry [::combobox::ComputeGeometry $widgets(this)] wm geometry $widgets(dropdown) $geometry update idletasks # if we are already open, there's nothing else to do if {[winfo ismapped $widgets(dropdown)]} { return 0 } # save the widget that currently has the focus; we'll restore # the focus there when we're done set oldFocus [focus] # ok, tweak the visual appearance of things and # make the list pop up $widgets(button) configure -relief sunken wm deiconify $widgets(dropdown) update idletasks raise $widgets(dropdown) # force focus to the entry widget so we can handle keypress # events for traversal focus -force $widgets(entry) # select something by default, but only if its an # exact match... ::combobox::Find $widgets(this) 1 # save the current grab state for the display containing # this widget. We'll restore it when we close the dropdown # list set status "none" set grab [grab current $widgets(this)] if {$grab != ""} {set status [grab status $grab]} set oldGrab [list $grab $status] unset grab status # *gasp* do a global grab!!! Mom always told me not to # do things like this, but sometimes a man's gotta do # what a man's gotta do. grab -global $widgets(this) # fake the listbox into thinking it has focus. This is # necessary to get scanning initialized properly in the # listbox. event generate $widgets(listbox) return 1 } close { # if we are already closed, don't do anything... if {![winfo ismapped $widgets(dropdown)]} { return 0 } # restore the focus and grab, but ignore any errors... # we're going to be paranoid and release the grab before # trying to set any other grab because we really really # really want to make sure the grab is released. catch {focus $oldFocus} result catch {grab release $widgets(this)} catch { set status [lindex $oldGrab 1] if {$status == "global"} { grab -global [lindex $oldGrab 0] } elseif {$status == "local"} { grab [lindex $oldGrab 0] } unset status } # hides the listbox $widgets(button) configure -relief raised wm withdraw $widgets(dropdown) # select the data in the entry widget. Not sure # why, other than observation seems to suggest that's # what windows widgets do. set editable [::combobox::GetBoolean $options(-editable)] if {$editable} { $widgets(entry) selection range 0 end $widgets(button) configure -relief raised } # magic tcl stuff (see tk.tcl in the distribution # lib directory) ::combobox::tkCancelRepeat return 1 } cget { if {[llength $args] != 1} { error "wrong # args: should be $w cget option" } set opt [::combobox::Canonize $w option [lindex $args 0]] if {$opt == "-value"} { set result [$widgets(entry) get] } else { set result $options($opt) } } configure { set result [eval ::combobox::Configure {$w} $args] } default { error "bad option \"$command\"" } } return $result } # ::combobox::Configure -- # # Implements the "configure" widget subcommand # # Arguments: # # w widget pathname # args zero or more option/value pairs (or a single option) # # Results: # # Performs typcial "configure" type requests on the widget proc ::combobox::Configure {w args} { variable widgetOptions variable defaultEntryCursor upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options if {[llength $args] == 0} { # hmmm. User must be wanting all configuration information # note that if the value of an array element is of length # one it is an alias, which needs to be handled slightly # differently set results {} foreach opt [lsort [array names widgetOptions]] { if {[llength $widgetOptions($opt)] == 1} { set alias $widgetOptions($opt) set optName $widgetOptions($alias) lappend results [list $opt $optName] } else { set optName [lindex $widgetOptions($opt) 0] set optClass [lindex $widgetOptions($opt) 1] set default [option get $w $optName $optClass] if {[info exists options($opt)]} { lappend results [list $opt $optName $optClass \ $default $options($opt)] } else { lappend results [list $opt $optName $optClass \ $default ""] } } } return $results } # one argument means we are looking for configuration # information on a single option if {[llength $args] == 1} { set opt [::combobox::Canonize $w option [lindex $args 0]] set optName [lindex $widgetOptions($opt) 0] set optClass [lindex $widgetOptions($opt) 1] set default [option get $w $optName $optClass] set results [list $opt $optName $optClass \ $default $options($opt)] return $results } # if we have an odd number of values, bail. if {[expr {[llength $args]%2}] == 1} { # hmmm. An odd number of elements in args error "value for \"[lindex $args end]\" missing" } # Great. An even number of options. Let's make sure they # are all valid before we do anything. Note that Canonize # will generate an error if it finds a bogus option; otherwise # it returns the canonical option name foreach {name value} $args { set name [::combobox::Canonize $w option $name] set opts($name) $value } # process all of the configuration options # some (actually, most) options require us to # do something, like change the attributes of # a widget or two. Here's where we do that... # # note that the handling of disabledforeground and # disabledbackground is a little wonky. First, we have # to deal with backwards compatibility (ie: tk 8.3 and below # didn't have such options for the entry widget), and # we have to deal with the fact we might want to disable # the entry widget but use the normal foreground/background # for when the combobox is not disabled, but not editable either. set updateVisual 0 foreach option [array names opts] { set newValue $opts($option) if {[info exists options($option)]} { set oldValue $options($option) } switch -- $option { -buttonbackground { $widgets(button) configure -background $newValue } -background { set updateVisual 1 set options($option) $newValue } -borderwidth { $widgets(frame) configure -borderwidth $newValue set options($option) $newValue } -command { # nothing else to do... set options($option) $newValue } -commandstate { # do some value checking... if {$newValue != "normal" && $newValue != "disabled"} { set options($option) $oldValue set message "bad state value \"$newValue\";" append message " must be normal or disabled" error $message } set options($option) $newValue } -cursor { $widgets(frame) configure -cursor $newValue $widgets(entry) configure -cursor $newValue $widgets(listbox) configure -cursor $newValue set options($option) $newValue } -disabledforeground { set updateVisual 1 set options($option) $newValue } -disabledbackground { set updateVisual 1 set options($option) $newValue } -dropdownwidth { set options($option) $newValue } -editable { set updateVisual 1 if {$newValue} { # it's editable... $widgets(entry) configure -state normal \ -cursor $defaultEntryCursor } else { $widgets(entry) configure -state disabled \ -cursor $options(-cursor) } set options($option) $newValue } -elementborderwidth { $widgets(button) configure -borderwidth $newValue $widgets(dropdown) configure -borderwidth $newValue set options($option) $newValue } -font { $widgets(entry) configure -font $newValue $widgets(listbox) configure -font $newValue set options($option) $newValue } -foreground { set updateVisual 1 set options($option) $newValue } -height { $widgets(listbox) configure -height $newValue HandleScrollbar $w set options($option) $newValue } -highlightbackground { $widgets(frame) configure -highlightbackground $newValue set options($option) $newValue } -highlightcolor { $widgets(frame) configure -highlightcolor $newValue set options($option) $newValue } -highlightthickness { $widgets(frame) configure -highlightthickness $newValue set options($option) $newValue } -image { if {[string length $newValue] > 0} { # puts "old button width: [$widgets(button) cget -width]" $widgets(button) configure \ -image $newValue \ -width [expr {[image width $newValue] + 2}] # puts "new button width: [$widgets(button) cget -width]" } else { $widgets(button) configure -image ::combobox::bimage } set options($option) $newValue } -listvar { if {[catch {$widgets(listbox) cget -listvar}]} { return -code error \ "-listvar not supported with this version of tk" } $widgets(listbox) configure -listvar $newValue set options($option) $newValue } -maxheight { # ComputeGeometry may dork with the actual height # of the listbox, so let's undork it $widgets(listbox) configure -height $options(-height) HandleScrollbar $w set options($option) $newValue } -opencommand { # nothing else to do... set options($option) $newValue } -relief { $widgets(frame) configure -relief $newValue set options($option) $newValue } -selectbackground { $widgets(entry) configure -selectbackground $newValue $widgets(listbox) configure -selectbackground $newValue set options($option) $newValue } -selectborderwidth { $widgets(entry) configure -selectborderwidth $newValue $widgets(listbox) configure -selectborderwidth $newValue set options($option) $newValue } -selectforeground { $widgets(entry) configure -selectforeground $newValue $widgets(listbox) configure -selectforeground $newValue set options($option) $newValue } -state { if {$newValue == "normal"} { set updateVisual 1 # it's enabled set editable [::combobox::GetBoolean \ $options(-editable)] if {$editable} { $widgets(entry) configure -state normal $widgets(entry) configure -takefocus 1 } # note that $widgets(button) is actually a label, # not a button. And being able to disable labels # wasn't possible until tk 8.3. (makes me wonder # why I chose to use a label, but that answer is # lost to antiquity) if {[info patchlevel] >= 8.3} { $widgets(button) configure -state normal } } elseif {$newValue == "disabled"} { set updateVisual 1 # it's disabled $widgets(entry) configure -state disabled $widgets(entry) configure -takefocus 0 # note that $widgets(button) is actually a label, # not a button. And being able to disable labels # wasn't possible until tk 8.3. (makes me wonder # why I chose to use a label, but that answer is # lost to antiquity) if {$::tcl_version >= 8.3} { $widgets(button) configure -state disabled } } else { set options($option) $oldValue set message "bad state value \"$newValue\";" append message " must be normal or disabled" error $message } set options($option) $newValue } -takefocus { $widgets(entry) configure -takefocus $newValue set options($option) $newValue } -textvariable { $widgets(entry) configure -textvariable $newValue set options($option) $newValue } -value { ::combobox::SetValue $widgets(this) $newValue set options($option) $newValue } -width { $widgets(entry) configure -width $newValue $widgets(listbox) configure -width $newValue set options($option) $newValue } -xscrollcommand { $widgets(entry) configure -xscrollcommand $newValue set options($option) $newValue } } if {$updateVisual} {UpdateVisualAttributes $w} } } # ::combobox::UpdateVisualAttributes -- # # sets the visual attributes (foreground, background mostly) # based on the current state of the widget (normal/disabled, # editable/non-editable) # # why a proc for such a simple thing? Well, in addition to the # various states of the widget, we also have to consider the # version of tk being used -- versions from 8.4 and beyond have # the notion of disabled foreground/background options for various # widgets. All of the permutations can get nasty, so we encapsulate # it all in one spot. # # note also that we don't handle all visual attributes here; just # the ones that depend on the state of the widget. The rest are # handled on a case by case basis # # Arguments: # w widget pathname # # Returns: # empty string proc ::combobox::UpdateVisualAttributes {w} { upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options if {$options(-state) == "normal"} { set foreground $options(-foreground) set background $options(-background) } elseif {$options(-state) == "disabled"} { set foreground $options(-disabledforeground) set background $options(-disabledbackground) } $widgets(entry) configure -foreground $foreground -background $background $widgets(listbox) configure -foreground $foreground -background $background $widgets(button) configure -foreground $foreground $widgets(frame) configure -background $background # we need to set the disabled colors in case our widget is disabled. # We could actually check for disabled-ness, but we also need to # check whether we're enabled but not editable, in which case the # entry widget is disabled but we still want the enabled colors. It's # easier just to set everything and be done with it. if {$::tcl_version >= 8.4} { $widgets(entry) configure \ -disabledforeground $foreground \ -disabledbackground $background $widgets(button) configure -disabledforeground $foreground $widgets(listbox) configure -disabledforeground $foreground } } # ::combobox::SetValue -- # # sets the value of the combobox and calls the -command, # if defined # # Arguments: # # w widget pathname # newValue the new value of the combobox # # Returns # # Empty string proc ::combobox::SetValue {w newValue} { upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options upvar ::combobox::${w}::ignoreTrace ignoreTrace upvar ::combobox::${w}::oldValue oldValue if {[info exists options(-textvariable)] \ && [string length $options(-textvariable)] > 0} { set variable ::$options(-textvariable) set $variable $newValue } else { set oldstate [$widgets(entry) cget -state] $widgets(entry) configure -state normal $widgets(entry) delete 0 end $widgets(entry) insert 0 $newValue $widgets(entry) configure -state $oldstate } # set our internal textvariable; this will cause any public # textvariable (ie: defined by the user) to be updated as # well # set ::combobox::${w}::entryTextVariable $newValue # redefine our concept of the "old value". Do it before running # any associated command so we can be sure it happens even # if the command somehow fails. set oldValue $newValue # call the associated command. The proc will handle whether or # not to actually call it, and with what args CallCommand $w $newValue return "" } # ::combobox::CallCommand -- # # calls the associated command, if any, appending the new # value to the command to be called. # # Arguments: # # w widget pathname # newValue the new value of the combobox # # Returns # # empty string proc ::combobox::CallCommand {w newValue} { upvar ::combobox::${w}::widgets widgets upvar ::combobox::${w}::options options # call the associated command, if defined and -commandstate is # set to "normal" if {$options(-commandstate) == "normal" && \ [string length $options(-command)] > 0} { set args [list $widgets(this) $newValue] uplevel \#0 $options(-command) $args } } # ::combobox::GetBoolean -- # # returns the value of a (presumably) boolean string (ie: it should # do the right thing if the string is "yes", "no", "true", 1, etc # # Arguments: # # value value to be converted # errorValue a default value to be returned in case of an error # # Returns: # # a 1 or zero, or the value of errorValue if the string isn't # a proper boolean value proc ::combobox::GetBoolean {value {errorValue 1}} { if {[catch {expr {([string trim $value])?1:0}} res]} { return $errorValue } else { return $res } } # ::combobox::convert -- # # public routine to convert %x, %y and %W binding substitutions. # Given an x, y and or %W value relative to a given widget, this # routine will convert the values to be relative to the combobox # widget. For example, it could be used in a binding like this: # # bind .combobox {doSomething [::combobox::convert %W -x %x]} # # Note that this procedure is *not* exported, but is intended for # public use. It is not exported because the name could easily # clash with existing commands. # # Arguments: # # w a widget path; typically the actual result of a %W # substitution in a binding. It should be either a # combobox widget or one of its subwidgets # # args should one or more of the following arguments or # pairs of arguments: # # -x will convert the value ; typically will # be the result of a %x substitution # -y will convert the value ; typically will # be the result of a %y substitution # -W (or -w) will return the name of the combobox widget # which is the parent of $w # # Returns: # # a list of the requested values. For example, a single -w will # result in a list of one items, the name of the combobox widget. # Supplying "-x 10 -y 20 -W" (in any order) will return a list of # three values: the converted x and y values, and the name of # the combobox widget. proc ::combobox::convert {w args} { set result {} if {![winfo exists $w]} { error "window \"$w\" doesn't exist" } while {[llength $args] > 0} { set option [lindex $args 0] set args [lrange $args 1 end] switch -exact -- $option { -x { set value [lindex $args 0] set args [lrange $args 1 end] set win $w while {[winfo class $win] != "Combobox"} { incr value [winfo x $win] set win [winfo parent $win] if {$win == "."} break } lappend result $value } -y { set value [lindex $args 0] set args [lrange $args 1 end] set win $w while {[winfo class $win] != "Combobox"} { incr value [winfo y $win] set win [winfo parent $win] if {$win == "."} break } lappend result $value } -w - -W { set win $w while {[winfo class $win] != "Combobox"} { set win [winfo parent $win] if {$win == "."} break; } lappend result $win } } } return $result } # ::combobox::Canonize -- # # takes a (possibly abbreviated) option or command name and either # returns the canonical name or an error # # Arguments: # # w widget pathname # object type of object to canonize; must be one of "command", # "option", "scan command" or "list command" # opt the option (or command) to be canonized # # Returns: # # Returns either the canonical form of an option or command, # or raises an error if the option or command is unknown or # ambiguous. proc ::combobox::Canonize {w object opt} { variable widgetOptions variable columnOptions variable widgetCommands variable listCommands variable scanCommands switch $object { command { if {[lsearch -exact $widgetCommands $opt] >= 0} { return $opt } # command names aren't stored in an array, and there # isn't a way to get all the matches in a list, so # we'll stuff the commands in a temporary array so # we can use [array names] set list $widgetCommands foreach element $list { set tmp($element) "" } set matches [array names tmp ${opt}*] } {list command} { if {[lsearch -exact $listCommands $opt] >= 0} { return $opt } # command names aren't stored in an array, and there # isn't a way to get all the matches in a list, so # we'll stuff the commands in a temporary array so # we can use [array names] set list $listCommands foreach element $list { set tmp($element) "" } set matches [array names tmp ${opt}*] } {scan command} { if {[lsearch -exact $scanCommands $opt] >= 0} { return $opt } # command names aren't stored in an array, and there # isn't a way to get all the matches in a list, so # we'll stuff the commands in a temporary array so # we can use [array names] set list $scanCommands foreach element $list { set tmp($element) "" } set matches [array names tmp ${opt}*] } option { if {[info exists widgetOptions($opt)] \ && [llength $widgetOptions($opt)] == 2} { return $opt } set list [array names widgetOptions] set matches [array names widgetOptions ${opt}*] } } if {[llength $matches] == 0} { set choices [HumanizeList $list] error "unknown $object \"$opt\"; must be one of $choices" } elseif {[llength $matches] == 1} { set opt [lindex $matches 0] # deal with option aliases switch $object { option { set opt [lindex $matches 0] if {[llength $widgetOptions($opt)] == 1} { set opt $widgetOptions($opt) } } } return $opt } else { set choices [HumanizeList $list] error "ambiguous $object \"$opt\"; must be one of $choices" } } # ::combobox::HumanizeList -- # # Returns a human-readable form of a list by separating items # by columns, but separating the last two elements with "or" # (eg: foo, bar or baz) # # Arguments: # # list a valid tcl list # # Results: # # A string which as all of the elements joined with ", " or # the word " or " proc ::combobox::HumanizeList {list} { if {[llength $list] == 1} { return [lindex $list 0] } else { set list [lsort $list] set secondToLast [expr {[llength $list] -2}] set most [lrange $list 0 $secondToLast] set last [lindex $list end] return "[join $most {, }] or $last" } } # This is some backwards-compatibility code to handle TIP 44 # (http://purl.org/tcl/tip/44.html). For all private tk commands # used by this widget, we'll make duplicates of the procs in the # combobox namespace. # # I'm not entirely convinced this is the right thing to do. I probably # shouldn't even be using the private commands. Then again, maybe the # private commands really should be public. Oh well; it works so it # must be OK... foreach command {TabToWindow CancelRepeat ListboxUpDown} { if {[llength [info commands ::combobox::tk$command]] == 1} break; set tmp [info commands tk$command] set proc ::combobox::tk$command if {[llength [info commands tk$command]] == 1} { set command [namespace which [lindex $tmp 0]] proc $proc {args} "uplevel $command \$args" } else { if {[llength [info commands ::tk::$command]] == 1} { proc $proc {args} "uplevel ::tk::$command \$args" } } } # end of combobox.tcl ###################################################################### # icon image data. ###################################################################### image create bitmap delta48 -data { #define delta48_width 48 #define delta48_height 48 static char delta48_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x80, 0x13, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x10, 0x00, 0x00, 0x00, 0x00, 0x40, 0x08, 0x00, 0x00, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x00, 0x00, 0x30, 0x0c, 0x00, 0x00, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x00, 0x00, 0x0c, 0x0e, 0x00, 0x00, 0x00, 0x00, 0x04, 0x1b, 0x00, 0x00, 0x00, 0x00, 0x06, 0x1b, 0x00, 0x00, 0x00, 0x00, 0x02, 0x33, 0x00, 0x00, 0x00, 0x00, 0x03, 0x2e, 0x00, 0x00, 0x00, 0x00, 0x11, 0x6c, 0x00, 0x00, 0x00, 0x00, 0x11, 0x68, 0x00, 0x00, 0x00, 0x80, 0x10, 0xc8, 0x00, 0x00, 0x00, 0x80, 0x10, 0xa8, 0x01, 0x00, 0x00, 0x80, 0x08, 0x08, 0x01, 0x00, 0x00, 0x80, 0x08, 0xac, 0x03, 0x00, 0x00, 0x80, 0x09, 0x06, 0x02, 0x00, 0x00, 0xc0, 0x09, 0xaa, 0x06, 0x00, 0x00, 0x40, 0x09, 0x01, 0x04, 0x00, 0x00, 0xe0, 0x93, 0xae, 0x0a, 0x00, 0x00, 0x30, 0x92, 0x06, 0x18, 0x00, 0x00, 0xb0, 0x92, 0xad, 0x1a, 0x00, 0x00, 0x18, 0x53, 0x04, 0x30, 0x00, 0x00, 0xa8, 0x11, 0xac, 0x2a, 0x00, 0x00, 0x0c, 0x12, 0x04, 0x60, 0x00, 0x00, 0xac, 0x12, 0xac, 0x6a, 0x00, 0x00, 0x02, 0x14, 0x04, 0x80, 0x00, 0x00, 0xab, 0x0a, 0xae, 0xaa, 0x01, 0x00, 0x01, 0x28, 0x02, 0x00, 0x01, 0x80, 0xab, 0x3a, 0xaf, 0xaa, 0x03, 0x80, 0x00, 0x70, 0x0c, 0x00, 0x02, 0xc0, 0xaa, 0x5a, 0xa8, 0xaa, 0x06, 0x40, 0x00, 0xa0, 0x08, 0x00, 0x0c, 0xa0, 0xaa, 0xea, 0xac, 0xaa, 0x0a, 0x30, 0x00, 0x80, 0x05, 0x00, 0x18, 0xb0, 0xaa, 0xaa, 0xab, 0xaa, 0x1a, 0x08, 0x00, 0x00, 0x04, 0x00, 0x30, 0xfc, 0xff, 0xff, 0xbe, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0xbd, 0xff, 0x7f, 0x00, 0x00, 0x00, 0x70, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, } } image create photo deltaGif -format gif -data { R0lGODlhMAAwAOf/AAUughEzYAQ5lgg3oh43YBQ4jQ46nyo1eBc9oyw7hA1CrQxDpxlAnyQ9nik/ exxApkE+QiNBlCVAmiBArQxJmhRGqxRItyVEqyhHlCZHpzRKXh5KsCpHrzpIeiBOkypLki9JnhVQ tCNMswlTxD5HmS1MrSRPrz9LhylQnS1OqChPtiBSvz5Nki1Sui9Rvwtfr0hRhSdWw0RSiyZXvlBS X1RPeyBazS5XzGROeSxZxzRco1ZUhVFWki9dxDBexR1j1Slhzk5bj1BamkRdrlZbi1ZcgGtXfyFn 02FgUi5mzVNgmlVhkERjuSVr0U9kkFNkmF1ijEVmtkxktT9ovWZigzNszDVtuR9x3VJnoF1nhSlx 0D1sxxJ442dmjDJyxG9ncnBliFVqsEdtw2lmmTFy2Xpjj6FiDIRkZkByx6VlAjB40atkB19vo2tt k6hnBoJsXkR4x0p3wEx2xTN9z6ppCmVxrYZrfK9oDlh1unJxklR4si2B2WB0vKVsJ61sDoFwij2A 2oxxa5VucT+CyDiE0DWGy1GAt7JwFEmDuEeDxDWJ24t2hXt4rLVzGDqKz1KDzEiHwnF9ukCMxZx5 WEGL10WLzLl2GzyPzlyGxFiHy5d7dEqNwZp8art4J4Z/nEyN1WCJu1qLxJKAj0iSzFWO0MB8I5SC hFKRzLp+McF9LFCTx2SOzF6RzpeGjr+CLlyUyWWTypOJoZWMp8aHNKKOi7SPZ8uMOKqRfamRg8aP R86PQraUd7qUitKTRs+WRtCXSL6ad7aciLqaoLGfodSbUsCehrKfrr6ej7uikdCgYcahftifVcmi c8Skc8ehlsmjecCli9uhWMqmid2kYdqnYsGpqsWsjuGoZcGul8ypqt6rZdKsidisd96sbdSuhNyu c9evf9SwkuOxcdiyjs21rde2hOW0eue0dN62hum2b+G3gei2fOO4fOO5g+u4eNS9m9/BoPPAhvDB me/Bn+/CpvHFiPTGkPXFtvnJmv/Ko/7KsPvNqv7Lt/7Opf/PwP/siyH+EUNyZWF0ZWQgd2l0aCBH SU1QACH5BAEKAP8ALAAAAAAwADAAAAj+AP8JHEiwoEGDbA4qXMiwYSQxWHA0nEjRIJMtaDA9MVKx 48QoWyitWiXDo0mFTOQAYgXrEYyTMAnKIaUI1ikvO2LGjIKJEilWcIb80XmSEZ5XlE7BCaOpD1GP U9Bk+pSUT7Ffh55WrBOHpaJPidgES+YqjdaJYUKxIrXn1KhNbZgRa3S2oR5Wrx6RcQvq2Ddqs+jU VdgG1KlTigCNQhTEExi5ncwMRnhK1SkulEZJGjRIx65uugRPHvhHj9tRVxxdIqQmCYoz36KlMjv6 HxVDqkYRSs36SI4Igcx1w1r7HxRIo0bNOTJHC5AbMSJwMncOsJvaTiSNqtTkR5XnOWL+fAC2bp24 uaPfLJF0qRCQJEDCx2ghg1n56oEnT1IiiTUQGzbEIKALRnBTHjviLNPJYHTUEkQhWiRhQw7QxdCD EMewU94652jTi2haNcJMF1bEN4KAM/QgBTbtbHhfNGVplcYs3bSiQ3gnztBCCnagg46LHA6X1VON ECMONEIIaEELM5RQAy+05OENkPhdpxMdtmhzTjuiZBCDAi20EAENX3xQwDNAmodeTGukEs057Lwz DAgrKKCCChmYkIQKEqBJJTW23BHTIb90c446svDhQwsGbKDCBpBuEIEyaZoXTSm0eTQjNeeUJ4oJ M6xgwJ2PQoqCn1R66MdJRYrT6Tr+yGBw5wMcRHrBBi80UymH07gCIkV0zMLphuBQkYEKD1xQ6wUX VICBfZV2+AtdFaVhyTLiAAnNCSpcYACzFVzAAAHQRgtYpg35oYuWQLZziwfeMtssBUgYuKuallCU hpuvAonOIgwMUMHAGWhgzb33aWPLrwoRauiu27BgwAMVPAAABLfgMg7C51xqpUJrCNtvmuGwMIEB FQMQgAMHBMOxh0Mq1CrC5eSxwcQKPGBCCB1IgzCH1MR4EJbsIizNEgxM/MDSWWz8czdrFpRGKdj+ XN42UDDwwMQMmKKO1fgx/A8dvRRt9TZjPLBAA0WAY3V5CVqCrhulvPn2gdaEIQCKCbjczaE2uqw6 UJHnxFPP4Ygnrng99lQDAg/wLC454u70ShsduriDTz+cd+75553vY0wK1ewD+umc4xNPNHRhmQ4+ +vAj++y01077PWUQkY0/tvfOjz75xDMXKtfEg4888ySv/PLMM+/MDljEIgw59DTPvDzy2HNOLnUZ I0gHBSQQS3Hkl29+bQEBADs= } image create photo findImg -format gif -data { R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr /7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP /0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAjUAAMIHEiwoEF3 AOQpXMiQIQB3ARC6a6fO3buHAiVWfAcPYwB1AN6pa/fQnUkAIy+qEwiy3bp07DqaPPmS3TqS Kz/SA8ATQDyB8XoCoJczI4B2F+VBjCjvocyBCNOVS9cxAE+rUqliRHhznbunEY96dbl15kyC Zs8OrDgzJ1uTRVnSYzcO5M8AQeu6I0oQ5DukAOAJlglPJVR5gBMifNjUqTyoAM6NK1f1auTJ YDuuOxdTKM/NneGFHVkRLEKKE0GeFGzRdODWMhd7Xipb6FKDuAsGBAA7 } image create photo ctrCDRImg -format gif -data { R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr /7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP /0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiUAAMIHBjAHYCD ANwRHHjOncOHBgkRSgjRYUOEGAEYMpQRoUMA/8SJFGdwY0JyKFFSBGCuZcuSHN25bLmyo0aO Nj+GJAkg0caNiU6q/DjToE9DQWW6rNkxUdCcBneONHhy5FCDM106zErzo82vB3XuTEm27Equ aJd6BQsVpFSRZcmeTYuWKduM7hpW3Lv33MK/gAUGBAA7 } image create photo firstCDRImg -format gif -data { R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr /7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP /0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiUAAMIdFevoMGD Bd0JXBig3j9ChAxJnDixHkOBDilqlGjxIkGEIBVevHjOnbtzI1MKLAkAwEmVJN0BIKTIJUqY AVgS+neo5kuVOv9J7Gkzpc5BFIn+XHg06SGlN1fKbDlTYiKqRRmWNFnV0FWTS7XqtGoz6six XrMClRkxbdizbMm+jQngUKK7ao1OxTo3JliTZgUGBAA7 } image create photo prevCDRImg -format gif -data { R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr /7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP /0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAiGAAMIHCjwnDt3 5wgqLHjQHQBChgwlAtAw4cIABh9GnIjwIsOH/yIeUkTR4sWMECWW9DgQJcmOJx0SGhRR5KGR Kxei3JjT406VMH06BECUaFCWGXsilfkP51GCKGnWdGryY9GUE4s+xfiT47mqCrsq1SmT51ao ZYGCDevwUKK3Y8k2PLg2IAA7 } image create photo nextCDRImg -format gif -data { R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr /7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP /0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAiGAAMIHHjOncGD 5wYqVFgQACFDhhIBcJdwIUN3DgsdUjSxokWBDR9G7PixIYCTIiWeJGmx4T9ChA6x/BggJESJ FGnWtDmSoseLGSFC3DizJMaiNE2uRLrQ5U2mQFNCJYhRak6dPHH+vGjQ4VOETasWEmrokFmO V6OOLYt2a1iHbXWGTbswIAA7 } image create photo lastCDRImg -format gif -data { R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr /7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP /0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiTAAMIHHjOncGD 5wYqVFgQgMOH7hIuZOgOwD9ChA4BiDiRokVDhhJtlNgxQENCIEVyLGmyIsqQI1meO5lyJEmK BgG8VGnwZsuHOmtCvHmyEEiQh5IqiumRkNGjh5auXFgUqVSfTQtFZSrT5VWWHrmCFVhwakl3 9dKqXZvW3cR6F18enVvv7b+5eEHWXYiWrV+3AgMCADs= } image create photo rediffImg -format gif -data { R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr /7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP /0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQCrPQCW MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAicAAMIHEiwoMF0 7AD0euVKl8OHrhjqAgDvnDsAGDOmG2jR3TmDIAVaxFiRoMJXKF/1ypgR5UqPIWOCTIfQnc2b ABpS/Bgg3cmUQIOqBHBxIUpYADYKLEqUp8ynUKMatFgy5LmrWEdOrDoQIcuvrnSWPJfQqFCg YhPCAtqrrduUL8/9fIWUJs2LQ2EGmFt34MWmBNPdvKlUquEAAQEAOw== } image create photo ignCDRImg -format gif -data { R0lGODlhFgAWAKIAANnZ2d0AAJ6enmJiYgAAAAC5AACWMQBQACH5BAEAAAAALAAAAAAWABYA AANwCLrc/jBKF8JcgtU6xSBDtlmRR2QCMZZfVhjGBj6mUrzxBoAZ9tmwXKWg4ClqAFzssHkV Q8gkLHAAMHHEnSD62lyDhiLqBxAOwc9ebRRQhnchhoeNTlNW5QXB2Bi1MHx9OgApH38RHA09 F4yNjo8MCQA7 } image create photo bkmSetImg -format gif -data { R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1Pjisd/UjtHJ a8O4SL2qJcWqAK+SAJN6AGJiAEpKADIyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr /7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP /0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiZAAMIHEhQoLqD CAsqFAigIQB3Dd0tNKjOXSxXrmABWBABgLqCByECuAir5EYJHimKvOgqFqxXrzZ2lBhgJUaY LV/GOpkSIqybOF3ClPlQIEShMF/lfLVzAcqPRhsKXRqTY1GCFaUy1ckTKkiRGhtapTkxa82u ExUSJZs2qtOUbQ2ujTsQ4luvbdXNpRtA712+UeEC7ou3YEAAADt= } image create photo bkmRlsImg -format gif -data { R0lGODlhFAAUAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1Pjisd/UjtHJ a8O4SL2qJcWqAK+SAJN6AGJiAEpKADIyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr /7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP /0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAAAiwAAMIHEhQoLqD CAsCWKhwIbyFANwNXBiD4UF3sVw9rLhQXQCKNTguzLgxZMePMWqo5OgqVkmVNwAIXHhDpUl3 7gCkhMkwJ02bHHfWiCkzQM5YP1cKJepRoM+kNoculEhQXc6cNW3GzNm0oFWdUSviLDgRbFST RRsuzYpWrVaoHMsujYgVKMOPUYkCWPCQbY2iP/UuiACgr9S0NDvulQBAXd+7ZYv6bPowLdmB By8LDAgAOw== } image create photo mrgC1Img -format gif -data { R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr /7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP /0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAiIAAMIHEiwYMFz 7gAQ+meoIaGHECEeAuDuoDt35wxqFIgQAMWMGzkmVHRooseTKD1WPAgy5MCOhAZRvEizJsaR hxrq3LkzEcWXIz+eG0qUqMujSJMixJg0AEyhRYuKVDjIUMqrMxUy5MnVkM+bAEgaOpSorNmz X6eSnGmzZkunCT825fh2btKAADt= } image create photo mrgC2Img -format gif -data { R0lGODdhFAAUAPf/AAAAAIAAAACAAICAAAAAgIAAgACAgMDAwMDcwKbK8P/w1P/isf/Ujv/G a/+4SP+qJf+qANySALl6AJZiAHNKAFAyAP/j1P/Hsf+rjv+Pa/9zSP9XJf9VANxJALk9AJYx AHMlAFAZAP/U1P+xsf+Ojv9ra/9ISP8lJf4AANwAALkAAJYAAHMAAFAAAP/U4/+xx/+Oq/9r j/9Ic/8lV/8AVdwASbkAPZYAMXMAJVAAGf/U8P+x4v+O1P9rxv9IuP8lqv8AqtwAkrkAepYA YnMASlAAMv/U//+x//+O//9r//9I//8l//4A/twA3LkAuZYAlnMAc1AAUPDU/+Kx/9SO/8Zr /7hI/6ol/6oA/5IA3HoAuWIAlkoAczIAUOPU/8ex/6uO/49r/3NI/1cl/1UA/0kA3D0AuTEA liUAcxkAUNTU/7Gx/46O/2tr/0hI/yUl/wAA/gAA3AAAuQAAlgAAcwAAUNTj/7HH/46r/2uP /0hz/yVX/wBV/wBJ3AA9uQAxlgAlcwAZUNTw/7Hi/47U/2vG/0i4/yWq/wCq/wCS3AB6uQBi lgBKcwAyUNT//7H//47//2v//0j//yX//wD+/gDc3AC5uQCWlgBzcwBQUNT/8LH/4o7/1Gv/ xkj/uCX/qgD/qgDckgC5egCWYgBzSgBQMtT/47H/x47/q2v/j0j/cyX/VwD/VQDcSQC5PQCW MQBzJQBQGdT/1LH/sY7/jmv/a0j/SCX/JQD+AADcAAC5AACWAABzAABQAOP/1Mf/sav/jo// a3P/SFf/JVX/AEncAD25ADGWACVzABlQAPD/1OL/sdT/jsb/a7j/SKr/Jar/AJLcAHq5AGKW AEpzADJQAP//1P//sf//jv//a///SP//Jf7+ANzcALm5AJaWAHNzAFBQAPLy8ubm5tra2s7O zsLCwra2tqqqqp6enpKSkoaGhnp6em5ubmJiYlZWVkpKSj4+PjIyMiYmJhoaGg4ODv/78KCg pICAgP8AAAD/AP//AAAA//8A/wD//////yH5BAEAAAEALAAAAAAUABQAQAiNAAMIHEiwYEF3 AP79GzSIkMOHhAwZKkQIgLtzBguec3cxo8eNACxiHIgwpMmTIQ8dUiTSo8aRBDdynEkTIcWW ARBGlMizJ8+VFgOcG0q0KEKWHV0qXcp0qUyYA4tKBVkxaU6UWAFMrIoR4SCfYCXe5AjgUKKz aNMeMgT0osyaNMsihfqxpNWmQ5s2DQgAOw== } image create photo mrgC12Img -format gif -data { R0lGODlhFAAUAPMHAAAAAAB6uQCS3CWq/0i4/47U/7Hi/////729vQAAAAAAAAAAAAAAAAAAAAAA AAAAACH5BAEAAAgALAAAAAAUABQAAAT+ECGEECgAIYQQggghhBBCCIFiAEQIIYQQQgghhCACxRAA AAAAAAABAAghUA4hpBRYSimllAEQAuVAQgghhBBCCCECAoRAGIQQQgghkBBCiAAIIRAGgUMIIYQQ QggBEEQIgTAGAAAAACAAAACEEEIgDAARQgghhBBCCCGIEAIBIIQQQghBhBBCCCGEEEIIIgQKQAgh hBBCECGEEEIImAIQggghAAAAAAAAAATEFIAQQmCUUmAppZRCCDkFIAQREIQQQgghhBBIyCkAISAI IYRAQgghhJARAEIACiGEEEIIIQYZMACEEAAAAAAAgACAMQJACCGEEEQIIYQQAiMAhCAPQgghhBBC CCEEQQAIIYQiADs= } image create photo mrgC21Img -format gif -data { R0lGODlhFAAUAPMHAAAAAAB6uQCS3CWq/0i4/47U/7Hi/////729vQAAAAAAAAAAAAAAAAAAAAAA AAAAACH5BAEAAAgALAAAAAAUABQAAAT+ECGEEEIIIYRAgQAhhBBCCCGEEEQIIWAKQAghBCAAAAAA AACAmAIBQgiBUUoppRRYCiHkFIAQAoJAQgghhBBCCDkFAoSAIIQQQgghkBBCRgAIASGEgEIIIYQY ZASAEEQAAAAAAAAAMOAIACGEEEIIIQQRQgiMABBCCCGIEEIIIYQQCABBhBBCCCEECkAIIoQQQggh hBBCEBQDEEIIIYQQggghhEAxBAAAAAQAAAAAQgiUQyAhpZRSSillAAQRKIcQQgghhBBICBEAIRAG IYRAQgghhBAiAEIIgjDIEEIIIYQQUAiAEEIgjAEAgAAAAAAAACGEEARhAIQQQgghhCAPQgghhEAA CCEEEUIIIYQiADs= } image create photo splitCDRImg -format gif -data { R0lGODlhFgAWALMAANnZ2ba2tkpKSp6enmJiYgAAAAC5AACWMQBQAP////////////////// /////////yH5BAEAAAAALAAAAAAWABYAAASKEMhJaRAD41G7DEQhipjXBYWhqoVgWmBxzEjB vUAQG/NRuy9diNercXTIJGHYOxR+gcFyOhURfYUQYTAYeUdXI4Cbk63O4Wyl22z3bB22uw2v oHyIvL5pUFO6X158cGQ6XIeHIoNaR0lJXDI9fT84hpFFdUFRl1hAlTGYN5+cTp44Ul8lOBMZ rRsRADs= } image create photo cmbinCDRImg -format gif -data { R0lGODlhFgAWAKIAANnZ2ba2tkpKSgAAAJ6engC5AACWMQBQACH5BAEAAAAALAAAAAAWABYA AAOACLrcEGKQ4OqCowxBbcOFYUgeA4riUCqneGwm8QUZ+spXhCtE7cK5wUgw6YV+u0ckNGg2 C8ehaSmCWqM3hhHF7ZK0wq54lFQODq6DuvvqXHpoZ5Or4XwiL2KgR9+4WT1JfCh1fw9lATR9 dit7YVVAjRFcLytvYVmWLJN+mpcTAAkAOw== } image create photo fldrImg -format gif -data { R0lGODlhFAAWAKIAANnZ2QAAAP/MmZlmMzMzM////////////yH5BAEAAAAALAAAAAAUABYA AANUCLrc/tCFSWdUQeitQ8xcWFnYEG6miAlD67Yn64Hx2RJTXQ84raO83C8U9A1vwiGqpwQy m5oilCVlWU3YKwsHCLy+YAK3Ky6bzzjCYsSuqC/w+CMBADs= } image create photo txtfImg -format gif -data { R0lGODlhFAAWAKIAANnZ2TMzM////wAAAJmZmf///////////yH5BAEAAAAALAAAAAAUABYA AANYGLq88BAEQaudIb5pO88R11UiuI3XBXFD61JDEM8nCrtujbcW4RODmq3yC0puuxcFKBwS jaykUsA8OntQpPTZvFZF2un3iu1ul1kyuuv8Bn7wuE8WkdqNCQA7 } image create photo ancfImg -format gif -data { R0lGODlhFAAUAJEAANnZ2QAAAD8/P////yH5BAEAAAAALAAAAAAUABQAAAJKRI6ZwB0N4Xsy WkpZttp57igdaCgYiVQGuAiAcEaHtsUNjNUjXfYMPFqUZp8MMaTaXDLAFUcYRB2dyovrZSMl r9yX1yVoDk3kRwEAOw== } image create photo bkmImg -format gif -data { R0lGODlhLgAWAJEAANnZ2czMzD8/P////yH5BAEAAAAALAAAAAAuABYAAAJyjI+py20CI3S0 JgFyFrZXrHHeyECbhKbqipYAqMXyTNPiYtb6Pt9KzgvqWgcMTIiMwUS5YzK5fISe1FdIuqk+ QZPAEgAOi8fkMtmIQJnX7HIX14633z+53f0qsfZ89ctHEuglBijo4VRo+KGi2Oj4eFAAADs= } image create photo nullImg image create bitmap resize -data { #define resize_width 14 #define resize_height 11 static char resize_bits[] = { 0x20, 0x01, 0x30, 0x03, 0x38, 0x07, 0x3c, 0x0f, 0x3e, 0x1f, 0x3f, 0x3f, 0x3e, 0x1f, 0x3c, 0x0f, 0x38, 0x07, 0x30, 0x03, 0x20, 0x01 } } # Despite the common naming the U/D arrows are LARGER than the L/R ones # (the former is used on a Dialog, the latter inside the toolbar) image create bitmap arroWu -data { #define arroWu_width 29 #define arroWu_height 15 static unsigned char arroWu_bits[] = { 0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00, 0x00,0x40,0x00,0x00, 0x00,0xe0,0x00,0x00, 0x00,0xf0,0x01,0x00, 0x00,0xf8,0x03,0x00, 0x00,0xfc,0x07,0x00, 0x00,0xfe,0x0f,0x00, 0x00,0xff,0x1f,0x00, 0x80,0xff,0x3f,0x00, 0xc0,0xff,0x7f,0x00, 0xe0,0xff,0xff,0x00, 0xf0,0xff,0xff,0x01, 0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00 } } image create bitmap arroWd -data { #define arroWd_width 29 #define arroWd_height 15 static unsigned char arroWd_bits[] = { 0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00, 0xf0,0xff,0xff,0x01, 0xe0,0xff,0xff,0x00, 0xc0,0xff,0x7f,0x00, 0x80,0xff,0x3f,0x00, 0x00,0xff,0x1f,0x00, 0x00,0xfe,0x0f,0x00, 0x00,0xfc,0x07,0x00, 0x00,0xf8,0x03,0x00, 0x00,0xf0,0x01,0x00, 0x00,0xe0,0x00,0x00, 0x00,0x40,0x00,0x00, 0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x00 } } image create bitmap arroWl -data { #define arroWl_width 10 #define arroWl_height 21 static unsigned char arroWl_bits[] = { 0x00,0x00,0x00,0x00, 0x00,0x00,0x00,0x01, 0x80,0x01,0xc0,0x01, 0xe0,0x01,0xf0,0x01, 0xf8,0x01,0xfc,0x01, 0xfe,0x01,0xfc,0x01, 0xf8,0x01,0xf0,0x01, 0xe0,0x01,0xc0,0x01, 0x80,0x01,0x00,0x01, 0x00,0x00,0x00,0x00, 0x00,0x00 } } image create bitmap arroWr -data { #define arroWr_width 10 #define arroWr_height 21 static unsigned char arroWr_bits[] = { 0x00,0x00,0x00,0x00, 0x00,0x00,0x02,0x00, 0x06,0x00,0x0e,0x00, 0x1e,0x00,0x3e,0x00, 0x7e,0x00,0xfe,0x00, 0xfe,0x01,0xfe,0x00, 0x7e,0x00,0x3e,0x00, 0x1e,0x00,0x0e,0x00, 0x06,0x00,0x02,0x00, 0x00,0x00,0x00,0x00, 0x00,0x00 } } # Tooltip popups # # tooltips version 0.1 # Paul Boyer # Science Applications International Corp. # # MODIFIED (for TkDiff) # 31Jul2018 mpm: NO-OP/UN-bind(s) if setting to an empty description ############################## # set_tooltips gets a button's name and the tooltip string as arguments # and creates the proper bindings for entering and leaving the button # Serves as the external interface to the feature # (helper procs carry a "i"nternal "T"ool "T"ip naming prefix) ############################## proc set_tooltips {widget tiptxt} { global g if {$tiptxt == {}} { bind $widget {} bind $widget {} bind $widget {} return } bind $widget " catch { after 500 { iTT_PopUp %W $tiptxt } } g(tooltip_id) " bind $widget {iTT_PopDown} bind $widget {iTT_PopDown} } ############################## # internal_tooltips_PopDown is used to de-activate the tooltip window ############################## proc iTT_PopDown {} { global g after cancel $g(tooltip_id) catch {destroy .tooltips_wind} } ############################## # internal_tooltips_PopUp is used to activate the tooltip window # # MODIFIED (for TkDiff) # 20Oct2020 mpm: TK issue? (lack of multi-monitor screen(x/y) ORIGIN) # (also tighten'd minor extraneous border, etc. pixels) ############################## proc iTT_PopUp {wid tiptxt} { global g w opts # get rid of other existing tooltips catch {destroy .tooltips_wind} toplevel .tooltips_wind -class ToolTip -highlightthickness 0 -bd 0 set size_changed 0 # get the cursor position set X [winfo pointerx $wid] set Y [winfo pointery $wid] # add a slight offset to make tooltips fall below cursor set Y [expr {$Y + 20}] # Now pop up the new widgetLabel wm overrideredirect .tooltips_wind 1 wm geometry .tooltips_wind +$X+$Y label .tooltips_wind.l -text $tiptxt -border 1 -relief raised \ -background $opts(inform) -foreground $w(foreground) pack .tooltips_wind.l # make invisible wm withdraw .tooltips_wind update idletasks # Dont let the ToolTip get CLIPPED by the screen edge # N.B> would have PREFERRED "winfo screen[x|y] $wid" but doesn't exist! # *mpm* (TK missing-feature bug?: can FAIL on 2nd,3rd...etc monitors) # Need to know SOME extent (aka display bounds) cursor is WITHIN !! lassign [iTT_scrnEdges $wid] na na RgtLoc BotLoc # adjust for bottom of screen if {($Y + [winfo reqheight .tooltips_wind]) > $BotLoc } { # ?? shouldn't the 25 REALLY be 2 times the original offset of 20 ?? set Y [expr {$BotLoc - [winfo reqheight .tooltips_wind] - 25}] set size_changed 1 } # adjust for right border of screen if {($X + [winfo reqwidth .tooltips_wind]) > $RgtLoc } { set X [expr {$RgtLoc - [winfo reqwidth .tooltips_wind]}] set size_changed 1 } # reset position if {$size_changed == 1} { wm geometry .tooltips_wind +$X+$Y } # make visible wm deiconify .tooltips_wind raise .tooltips_wind ;# Reqd MacOS (no harm anybody else): AFTER deiconify! # make tooltip disappear after 5 sec set g(tooltip_id) [after 5000 { iTT_PopDown }] } ############################################################################### # internal_tooltips_scrnEdges is used to avoid clipping the tooltip window # # TK-BUG/oversight/failure: # In a multi-screen configuration, TK fails to provide a means to LOCATE the # screen edges. Historically (aka: single screen) the location was IMPLIED to # be at (0,0), thus only the width/height were ever provided. However, it is # UNCLEAR the PROPER (W,H) is being returned when requested, as the POSITION of # the requestor can appear to be OUTSIDE that returned (0,0)-based (W,H). # This proc compensates (poorly) by USING the (W,H) when it "appears" to be # valid, and substitutes the dimensions of its "Toplevel" when not. As such it # must be possible to ASK for the position/size of a REALIZED toplevel (not # one still under construction, or incompletely modified). Be careful! # # Arg: the same as "winfo screen(width/height)": an 'exemplar' window # # Returns: list of 4 (position) values "minX minY maxX maxY" of edges to USE ############################################################################### proc iTT_scrnEdges { win } { lassign "[winfo vrootx $win] [winfo vrooty $win] [winfo rootx $win] [winfo rooty $win] [winfo width $win] [winfo height $win] 0 0 [winfo screenw $win] [winfo screenh $win]" vx vy x y w h X Y W H # If the LOCATION of the exemplar window is WITHIN the TK-provided screen # width/height, then use IT; otherwise fallback to using the Toplevel it # belongs to (best option - lousy though it is)! # ('inclusion' test LOOKS for any aspect of non-inclusion: 0==inside) if {($x+$vx+$w<$X) ||($x+$vx+$w>$X+$W) ||($x+$vx<$X) ||($x+$vx>$X+$W) || ($y+$vy+$h<$Y) ||($y+$vy+$h>$Y+$H) ||($y+$vy<$Y) ||($y+$vy>$Y+$H)} { set TL [winfo toplevel $win] lassign "[winfo rootx $TL] [winfo rooty $TL] [winfo width $TL] [winfo height $TL]" X Y W H incr W $X incr H $Y } return "$X $Y $W $H" } proc get_gtk_params { } { global w tk_version if {! [llength [auto_execok xrdb]]} { return 0 } set pipe [open "|xrdb -q" r] while {[gets $pipe ln] > -1} { switch -glob -- $ln { {\*Toplevel.background:*} { set bg [lindex $ln 1] } {\*Toplevel.foreground:*} { set fg [lindex $ln 1] } {\*Text.background:*} { set textbg [lindex $ln 1] } {\*Text.foreground:*} { set textfg [lindex $ln 1] } {\*Text.selectBackground:*} { set hlbg [lindex $ln 1] } {\*Text.selectForeground:*} { set hlfg [lindex $ln 1] } } } close $pipe if {! [info exists bg] || ! [info exists fg]} { return 0 } set w(selcolor) $hlbg option add *Entry.Background $textbg option add *Entry.Foreground $textfg option add *Entry.selectBackground $hlbg option add *Entry.selectForeground $hlfg option add *Entry.readonlyBackground $bg option add *Listbox.background $textbg option add *Listbox.selectBackground $hlbg option add *Listbox.selectForeground $hlfg option add *Text.Background $textbg option add *Text.Foreground $textfg option add *Text.selectBackground $hlbg option add *Text.selectForeground $hlfg # Menu checkboxes if {$tk_version >= 8.5} { option add *Menu.selectColor $fg option add *Checkbutton.selectColor "" option add *Radiobutton.selectColor "" } { option add *selectColor $w(selcolor) } return 1 } proc get_cde_params {} { global w tk_version # Set defaults for all the necessary things set bg [option get . background background] set fg [option get . foreground foreground] set guifont [option get . buttonFontList buttonFontList] set txtfont [option get . FontSet FontSet] set listfont [option get . textFontList textFontList] set textbg white set textfg black # If any of these AREN'T set, I don't think we're in CDE after all if {![string length $fg]} { return 0 } if {![string length $bg]} { return 0 } if {![string length $guifont]} { # For AIX set guifont [option get . FontList FontList] } if {![string length $guifont]} { return 0 } if {![string length $txtfont]} { return 0 } set guifont [string trimright $guifont ":"] set txtfont [string trimright $txtfont ":"] set listfont [string trimright $txtfont ":"] regsub {medium} $txtfont "bold" dlgfont # They don't tell us the slightly darker color they use for the # scrollbar backgrounds and graphics backgrounds, so we'll make # one up. set rgb_bg [winfo rgb . $bg] set shadow [format #%02x%02x%02x \ [expr {(9*[lindex $rgb_bg 0]) /2560}] \ [expr {(9*[lindex $rgb_bg 1]) /2560}] \ [expr {(9*[lindex $rgb_bg 2]) /2560}]] # If we can find the user's dt.resources file, we can find out the # palette and background/foreground colors set fh "" set palette "" set cur_rsrc ~/.dt/sessions/current/dt.resources set hom_rsrc ~/.dt/sessions/home/dt.resources if {[file readable $cur_rsrc] && [file readable $hom_rsrc]} { # Both exist. Use whichever is newer if {[file mtime $cur_rsrc] > [file mtime $hom_rsrc]} { if {[catch {open $cur_rsrc r} fh]} { set fh "" } } else { if {[catch {open $hom_rsrc r} fh]} { set fh "" } } } elseif {[file readable $cur_rsrc]} { if {[catch {open $cur_rsrc r} fh]} { set fh "" } } elseif {[file readable $hom_rsrc]} { if {[catch {open $hom_rsrc r} fh]} { set fh "" } } if {[string length $fh]} { set palf "" while {[gets $fh ln] != -1} { regexp "^\\*background:\[ \t]*(.*)\$" $ln nil textbg regexp "^\\*foreground:\[ \t]*(.*)\$" $ln nil textfg regexp "^\\*0\\*ColorPalette:\[ \t]*(.*)\$" $ln nil palette regexp "^Window.Color.Background:\[ \t]*(.*)\$" $ln nil textbg regexp "^Window.Color.Foreground:\[ \t]*(.*)\$" $ln nil textfg } catch {close $fh} # # If the *0*ColorPalette setting was found above, try to find the # indicated file in ~/.dt, $DTHOME, or /usr/dt. # if {[string length $palette]} { foreach dtdir {/usr/dt /etc/dt ~/.dt} { # This uses the last palette that we find if {[file readable [file join $dtdir palettes $palette]]} { set palf [file join $dtdir palettes $palette] } } # Dbg "Using palette $palf" if {[string length $palf]} { if {![catch {open $palf r} fh]} { gets $fh activetitle gets $fh inactivetitle gets $fh wkspc1 gets $fh textbg gets $fh guibg ;#(*.background) - default for tk under cde gets $fh menubg gets $fh wkspc4 gets $fh iconbg ;#control panel bg too close $fh option add *Text.highlightColor $wkspc4 option add *Dialog.Background $menubg option add *Menu.Background $menubg option add *Menu.activeBackground $menubg option add *Menu.activeForeground $fg option add *Menubutton.Background $menubg option add *Menubutton.activeBackground $menubg option add *Menubutton.activeForeground $fg } } } } else { Dbg "Neither ~/.dt/sessions/current/dt.resources nor\n\ ~/.dt/sessions/home/dt.resources was readable\n\ Falling back to plain X" return 0 } if {[info exists activetitle]} { set hlbg $activetitle } { set hlbg "#b24d7a" } set w(selcolor) $hlbg option add *Button.activeBackground $bg option add *Button.activeForeground $fg option add *Canvas.Background $shadow option add *Canvas.Foreground black option add *Entry.Background $textbg option add *Entry.Foreground $textfg option add *Entry.readonlyBackground $bg option add *Entry.highlightBackground $bg option add *Entry.highlightColor $hlbg option add *Listbox.background $textbg option add *Listbox.selectBackground $w(selcolor) option add *Listbox.selectForeground $fg option add *Menu.borderWidth 1 option add *Scrollbar.activeBackground $bg option add *Scrollbar.troughColor $shadow option add *Text.Background $textbg option add *Text.Foreground $textfg option add *Text.highlightBackground $bg # Menu checkboxes if {$tk_version >= 8.5} { # This makes it look like the native CDE checkbox option add *Menu.selectColor $fg option add *Checkbutton.offRelief sunken option add *Checkbutton.selectColor "" option add *Radiobutton.selectColor "" option add *Checkbutton.activeBackground $bg option add *Checkbutton.activeForeground $fg } { option add *selectColor $w(selcolor) } # Suppress the border option add *HighlightThickness 0 userDefault # Add it back for text and entry widgets option add *Text.HighlightThickness 2 userDefault option add *Entry.HighlightThickness 1 userDefault return 1 } proc get_aqua_params {} { global w # Keep everything from being blinding white option add *Frame.background #ebebeb userDefault option add *Label.background #ebebeb userDefault option add *Checkbutton.Background #ebebeb userDefault option add *Radiobutton.Background #ebebeb userDefault option add *Message.Background #ebebeb userDefault # or else there are little white boxes around the button "pill" option add *Button.highlightBackground #ebebeb userDefault option add *Entry.highlightBackground #ebebeb userDefault } ############################################################################### # run the main proc main