#----------------------------------------------------------------------
# Eskil, Directory diff section
#
# Copyright (c) 1998-2010, Peter Spjuth (peter.spjuth@gmail.com)
#
# 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; see the file COPYING. If not, write to
# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
#
#----------------------------------------------------------------------
# $Revision$
#----------------------------------------------------------------------
# Compare file names
proc FStrCmp {s1 s2} {
# Equality is based on platform's standard
# Order is dictionary order
# Exact equal is equal regardless of platform.
if {$s1 eq $s2} {
return 0
}
# Accept case insensitive equality on windows
if {$::tcl_platform(platform) eq "windows"} {
if {[string equal -nocase $s1 $s2]} {
return 0
}
}
# FIXA: What's the case on Mac?
if {[lindex [lsort -dictionary [list $s1 $s2]] 0] eq $s1} {
return -1
}
return 1
}
# Sort file names
proc Fsort {lst} {
lsort -dictionary $lst
}
# Compare two files or dirs
# Return true if equal
proc CompareFiles {file1 file2} {
if {[catch {file lstat $file1 stat1}]} {
return 0
}
if {[catch {file lstat $file2 stat2}]} {
return 0
}
# Same type?
set isdir1 [FileIsDirectory $file1]
set isdir2 [FileIsDirectory $file2]
if {$isdir1 != $isdir2} {
return 0
}
# Handle links
if {$stat1(type) eq "link" && $stat2(type) eq "link"} {
set l1 [file link $file1]
set l2 [file link $file2]
# Equal links are considered equal, otherwise check contents
if {$l1 eq $l2} {
return 1
}
file stat $file1 stat1
file stat $file2 stat2
}
# If contents is not checked, same size is enough to be equal
if {$stat1(size) == $stat2(size) && $::Pref(dir,comparelevel) == 0} {
return 1
}
set anyPlugin $::eskil(.dirdiff,dirPlugin)
set ignorekey $::Pref(dir,ignorekey)
set nocase $::Pref(nocase)
# Different size is enough when doing binary compare
if {$stat1(size) != $stat2(size) && $::Pref(dir,comparelevel) == 2 \
&& !$ignorekey && !$anyPlugin} {
return 0
}
# Don't check further if contents should not be checked
if {$::Pref(dir,comparelevel) == 0} {
return 0
}
# Don't check further if any is a directory
if {$isdir1 || $isdir2} {
# Consider dirs equal until we implement something recursive
return 1
}
switch $::Pref(dir,comparelevel) {
2 -
1 { # Check contents internally
set bufsz 65536
set eq 2 ;# 2 = equal this far, 1 = equal, 0 = not equal
set ch1 [open $file1 r]
set ch2 [open $file2 r]
if {$::Pref(dir,comparelevel) == 2} {
fconfigure $ch1 -translation binary
fconfigure $ch2 -translation binary
}
# Allow a plugin to do its thing
if {$anyPlugin} {
#puts "PLUGIN!"
$::eskil(.dirdiff,plugin,$anyPlugin) eval \
[list array set ::Pref [array get ::Pref]]
$::eskil(.dirdiff,plugin,$anyPlugin) eval \
[list set ::argv $::eskil(argv)]
interp share {} $ch1 $::eskil(.dirdiff,plugin,$anyPlugin)
interp share {} $ch2 $::eskil(.dirdiff,plugin,$anyPlugin)
set info1 [dict create name $file1 size $stat1(size)]
set info2 [dict create name $file2 size $stat2(size)]
set eq [$::eskil(.dirdiff,plugin,$anyPlugin) eval \
[list FileCompare $ch1 $ch2 $info1 $info2]]
set allow [dict get $::eskil(.dirdiff,pluginpinfo,$anyPlugin) allow]
if {$allow} {
$::eskil(.dirdiff,plugin,$anyPlugin) eval close $ch1
$::eskil(.dirdiff,plugin,$anyPlugin) eval close $ch2
} else {
$::eskil(.dirdiff,plugin,$anyPlugin) invokehidden close $ch1
$::eskil(.dirdiff,plugin,$anyPlugin) invokehidden close $ch2
}
}
if {$ignorekey} {
# Assume that all keywords are in the first block
set f1 [read $ch1 $bufsz]
set f2 [read $ch2 $bufsz]
regsub -all {\$\w+:[^\$]*\$} $f1 {} f1
regsub -all {\$\w+:[^\$]*\$} $f2 {} f2
# Compensate for any change in length
if {[string length $f1] < [string length $f2]} {
append f1 [read $ch1 [expr {[string length $f2] - [string length $f1]}]]
}
if {[string length $f2] < [string length $f1]} {
append f2 [read $ch2 [expr {[string length $f1] - [string length $f2]}]]
}
if {$nocase} {
if { ! [string equal -nocase $f1 $f2]} {
set eq 0
}
} else {
if { ! [string equal $f1 $f2]} {
set eq 0
}
}
}
while {$eq == 2 && ![eof $ch1] && ![eof $ch2]} {
set f1 [read $ch1 $bufsz]
set f2 [read $ch2 $bufsz]
if {$nocase} {
if { ! [string equal -nocase $f1 $f2]} {
set eq 0
}
} else {
if { ! [string equal $f1 $f2]} {
set eq 0
}
}
# It has been observered that sometimes channels fail to
# signal eof. Maybe when they come from a pipe?
# Protect by noticing empty strings.
if {[string equal $f1 ""] || [string equal $f2 ""]} {
break
}
}
if {$eq == 2 && (![eof $ch1] || ![eof $ch2])} {
set eq 0
}
# Errors during close are not interesting
catch {close $ch1}
catch {close $ch2}
}
}
return [expr {$eq != 0}]
}
# Returns the contents of a directory as a sorted list of full file paths.
proc DirContents {dir} {
if {$::tcl_platform(platform) eq "windows"} {
# .-files are not treated specially on windows. * is enough to get all
set files [glob -directory $dir -nocomplain *]
} else {
set files [glob -directory $dir -nocomplain *]
# Handle .-files and make sure no duplicates are generated
set files2 [glob -directory $dir -nocomplain {.[a-zA-Z]*}]
foreach file $files2 {
if {$file ni $files} {
lappend files $file
}
}
}
if {$::Pref(dir,onlyrev)} {
# FIXA: move to rev and make general for other systems
set entries [file join $dir CVS Entries]
if {[file exists $entries]} {
set ch [open $entries r]
set data [read $ch]
close $ch
foreach line [split $data \n] {
set name [lindex [split $line /] 1]
set controlled($name) 1
}
set files2 {}
foreach file $files {
if {[info exists controlled($file)]} {
lappend files2 $file
}
}
set files $files2
}
}
set files2 {}
foreach file $files {
set full $file
set tail [file tail $file]
# Apply filters
if {[FileIsDirectory $full]} {
if {[llength $::Pref(dir,incdirs)] == 0} {
set allowed 1
} else {
set allowed 0
foreach pat $::Pref(dir,incdirs) {
if {[string match $pat $tail]} {
set allowed 1
break
}
}
}
if {$allowed} {
foreach pat $::Pref(dir,exdirs) {
if {[string match $pat $tail]} {
set allowed 0
break
}
}
}
if { ! $allowed} continue
} else {
if {[llength $::Pref(dir,incfiles)] == 0} {
set allowed 1
} else {
set allowed 0
foreach pat $::Pref(dir,incfiles) {
if {[string match $pat $tail]} {
set allowed 1
break
}
}
}
if {$allowed} {
foreach pat $::Pref(dir,exfiles) {
if {[string match $pat $tail]} {
set allowed 0
break
}
}
}
if { ! $allowed} continue
}
lappend files2 $full
}
return [Fsort $files2]
}
# Bring up an editor to display a file.
proc EditFile {file} {
locateEditor ::util(editor)
# util(editor) may contain options, and is treated as a pre-command
exec {*}$::util(editor) $file &
}
# Pick a directory for compare
proc BrowseDir {dirVar entryW} {
upvar "#0" $dirVar dir
set newdir $dir
while {$newdir != "." && ![FileIsDirectory $newdir]} {
set newdir [file dirname $newdir]
}
set newdir [tk_chooseDirectory -initialdir $newdir -title "Select Directory"]
if {$newdir != ""} {
set dir $newdir
$entryW xview end
}
}
snit::widget DirCompareTree {
hulltype ttk::frame
component tree
component hsb
component vsb
option -leftdirvariable -default "" -configuremethod SetDirOption
option -rightdirvariable -default "" -configuremethod SetDirOption
option -statusvar -default ""
option -changelist -default ""
option -norun -default 0
# TODO: better name for experimental parameter
option -bepa -default 0
variable AfterId ""
variable DebugCh ""
variable DebugTime {}
variable PauseBgProcessing 0
variable ScheduledRestart 0
variable AfterTime 1
variable WorkTime 200
variable IdleQueue {}
variable IdleQueueArr
variable NodeStatus
variable leftMark ""
variable rightMark ""
variable leftDir ""
variable rightDir ""
variable protect {left 0 right 0}
constructor {args} {
variable color
install tree using tablelist::tablelist $win.tree -height 20 \
-movablecolumns no -setgrid no -showseparators yes \
-expandcommand [mymethod expandCmd] \
-collapsecommand [mymethod collapseCmd] \
-fullseparators yes -selectmode none \
-columns {0 "Structure" 0 Size 0 Date 0 Copy 0 Size 0 Date}
install vsb using ttk::scrollbar $win.vsb -orient vertical \
-command "$tree yview"
install hsb using ttk::scrollbar $win.hsb -orient horizontal \
-command "$tree xview"
set AfterId ""
set IdleQueue {}
$tree configure -yscrollcommand "$vsb set" -xscrollcommand "$hsb set"
$tree columnconfigure 0 -name structure
$tree columnconfigure 1 -name leftsize -align right
$tree columnconfigure 2 -name leftdate
$tree columnconfigure 3 -name command
$tree columnconfigure 4 -name rightsize -align right
$tree columnconfigure 5 -name rightdate
destroy [$tree separatorpath 1] [$tree separatorpath 4]
set color(unknown) grey
set color(unknown2) grey
set color(empty) grey
set color(equal) {}
set color(new) green
set color(old) blue
set color(change) red
#-expandcommand expandCmd
#bind $tree <<TreeviewOpen>> "[mymethod UpdateDirNode] \[%W focus\]"
set bodyTag [$tree bodytag]
bind $bodyTag <<Button3>> [bind TablelistBody <Button-1>]
bind $bodyTag <<Button3>> +[bind TablelistBody <ButtonRelease-1>]
bind $bodyTag <<Button3>> "+[mymethod ContextMenu] %W %x %y %X %Y"
bind $bodyTag <Double-1> "[mymethod DoubleClick] %W %x %y"
bind $bodyTag <Key-Return> [mymethod KeyReturn]
grid $tree $vsb -sticky nsew
grid $hsb -sticky nsew
grid columnconfigure $win 0 -weight 1
grid rowconfigure $win 0 -weight 1
$self configurelist $args
#$self ReStart
}
destructor {
if {$AfterId ne ""} {
after cancel $AfterId
}
set AfterId ""
}
method SetDirOption {option value} {
set options($option) $value
if {$options(-leftdirvariable) eq ""} return
upvar \#0 $options(-leftdirvariable) left
if { ! [info exists left]} return
if { ! [file isdirectory $left]} return
if {$options(-rightdirvariable) eq ""} return
upvar \#0 $options(-rightdirvariable) right
if { ! [info exists right]} return
if { ! [file isdirectory $right]} return
set leftDir $left
set rightDir $right
if { ! $ScheduledRestart} {
set ScheduledRestart 1
after idle [mymethod ReStart]
}
}
method newTopDir {newLeft newRight} {
if {$newLeft ne "" && [file isdirectory $newLeft]} {
upvar \#0 $options(-leftdirvariable) left
set left $newLeft
set leftDir $left
}
if {$newRight ne "" && [file isdirectory $newRight]} {
upvar \#0 $options(-rightdirvariable) right
set right $newRight
set rightDir $right
}
if { ! $ScheduledRestart} {
set ScheduledRestart 1
after idle [mymethod ReStart]
}
}
method nice {ms} {
# Sanity check
if {$ms < 1} { set ms 1 }
if {$ms > 1000} {set ms 1000 }
set AfterTime $ms
}
method ReStart {} {
# Delete all idle processing
if {$AfterId ne ""} {
after cancel $AfterId
}
if {$DebugCh ne ""} {
close $DebugCh
set DebugCh ""
set DebugTime {}
}
# Uncomment to activate debug logging
#set DebugCh [open ~/dirdiff.log a]
#$self DlogTablelist
$self Dlog RESTART
set AfterId ""
set IdleQueue {}
set ScheduledRestart 0
array unset IdleQueueArr
set protect {left 0 right 0}
if {$options(-norun)} {
set options(-norun) 0
return
}
# Directory Diff only supports one plugin.
# Find if any configured plugin supports dir diff and choose it.
set ::eskil(.dirdiff,dirPlugin) 0
foreach item [lsort -dictionary [array names ::eskil .dirdiff,pluginname,*]] {
set n [lindex [split $item ","] end]
if {$::eskil(.dirdiff,plugin,$n) ne "" && \
[dict get $::eskil(.dirdiff,pluginpinfo,$n) dir]} {
set ::eskil(.dirdiff,dirPlugin) $n
break
}
}
# Fill in clean root data
$tree delete 0 end
set topIndex [$tree insertchild root end {}]
set d1 [file tail $leftDir]
set d2 [file tail $rightDir]
if {$d1 eq $d2} {
$tree cellconfigure $topIndex,structure -text $d1
} else {
$tree cellconfigure $topIndex,structure -text "$d1 vs $d2"
}
$tree cellconfigure $topIndex,structure -image $::img(open)
$tree rowattrib $topIndex type directory
set NodeStatus($topIndex) ""
$self SetNodeStatus $topIndex empty
$tree rowattrib $topIndex leftfull $leftDir
$tree rowattrib $topIndex rightfull $rightDir
$self UpdateDirNode $topIndex
}
method expandCmd {tbl row} {
if {[$tree childcount $row] != 0} {
$tree cellconfigure $row,0 -image $::img(open)
}
}
method collapseCmd {tbl row} {
$tree cellconfigure $row,0 -image $::img(clsd)
}
# Format a time stamp for display
proc FormatDate {date} {
clock format $date -format "%Y-%m-%d %H:%M:%S"
}
method busyCursor {} {
variable oldcursor
if { ! [info exists oldcursor]} {
set oldcursor(hull) [$hull cget -cursor]
set oldcursor(tree) [$tree cget -cursor]
}
$hull configure -cursor watch
$tree configure -cursor watch
}
method normalCursor {} {
variable oldcursor
$hull configure -cursor $oldcursor(hull)
$tree configure -cursor $oldcursor(tree)
}
# Remove all equal nodes from tree
method PruneEqual {} {
$self busyCursor
set todo [$tree childkeys root]
while {[llength $todo] > 0} {
set todoNow $todo
set todo {}
foreach node $todoNow {
set status $NodeStatus($node)
if {$status eq "equal"} {
$tree delete $node
} else {
lappend todo {*}[$tree childkeys $node]
}
}
}
$self normalCursor
}
# Remove all empty dir nodes from tree
method PruneEmpty {} {
$self busyCursor
set redo 1
while {$redo} {
set redo 0
set todo [$tree childkeys root]
while {[llength $todo] > 0} {
set todoNow $todo
set todo {}
foreach node $todoNow {
set status $NodeStatus($node)
set children [$tree childkeys $node]
if {[llength $children] == 0} {
set type [$tree rowattrib $node type]
if {$type eq "directory"} {
$tree delete $node
set redo 1
}
} else {
lappend todo {*}$children
}
}
}
}
$self normalCursor
}
# Remove all nodes that are just on one side
method PruneAlone {} {
$self busyCursor
set todo [$tree childkeys root]
while {[llength $todo] > 0} {
set todoNow $todo
set todo {}
foreach node $todoNow {
set status $NodeStatus($node)
if {$status in {new old}} {
$tree delete $node
} else {
lappend todo {*}[$tree childkeys $node]
}
}
}
$self normalCursor
}
# Open or close all directories in the tree view
method OpenAll {{state 1}} {
if {$state} {
$tree expandall
} else {
$tree collapseall
}
}
# Create a directory missing on one side
method CreateDir {node to} {
set lf [$tree rowattrib $node leftfull]
set rf [$tree rowattrib $node rightfull]
set parent [$tree parent $node]
set lp [$tree rowattrib $parent leftfull]
set rp [$tree rowattrib $parent rightfull]
if {$to eq "right"} {
set src $lf
if {$rp ne ""} {
set dst [file join $rp [file tail $src]]
} else {
return
}
} elseif {$to eq "left"} {
set src $rf
if {$lp ne ""} {
set dst [file join $lp [file tail $src]]
} else {
return
}
} else {
error "Bad from argument to CreateDir: $to"
}
if {[tk_messageBox -icon question -title "Create dir?" -message \
"Create\n$dst ?" -type yesno] eq "yes"} {
file mkdir $dst
# FIXA: update file info in tree too
#$self SetNodeStatus $node equal
}
}
# Copy a file from one directory to the other
method CopyFile {node from} {
##nagelfar vartype tree _obj,tablelist
if {$from eq "left"} {
set to right
} elseif {$from eq "right"} {
set to left
} else {
error "Bad from argument to CopyFile: $from"
}
set fromf [$tree rowattrib $node ${from}full]
set tof [$tree rowattrib $node ${to}full]
set parent [$tree parent $node]
set fromp [$tree rowattrib $parent ${from}full]
set top [$tree rowattrib $parent ${to}full]
set src $fromf
if {$tof ne ""} {
set dst $tof
} else {
# Go up until we find a common parent
set dst [file tail $src]
set Count 0 ;# Safety check while debugging
while {$Count < 1000} {
if {[incr Count] > 999} {
error "Internal error in CopyFile $from"
}
if {$top ne ""} {
set dst [file join $top $dst]
break
}
# Continue up to a commmon parent
set dst [file join [file tail $fromp] $dst]
set parent [$tree parent $parent]
set fromp [$tree rowattrib $parent ${from}full]
set top [$tree rowattrib $parent ${to}full]
}
}
if {[file exists $dst]} {
if {[tk_messageBox -icon question -title "Overwrite file?" -message \
"Copy\n$src\n\noverwriting\n$dst ?" -type yesno] eq "yes"} {
file copy -force $src $dst
# FIXA: update file info in tree too
$self SetNodeStatus $node equal
}
} else {
set msg "Copy\n$src\nto\n$dst ?"
set dstdir [file dirname $dst]
if { ! [file isdirectory $dstdir]} {
append msg "\nCreating Directory\n$dstdir ?"
}
if {[tk_messageBox -icon question -title "Copy file?" -message \
$msg -type yesno] eq "yes"} {
if { ! [file isdirectory $dstdir]} {
file mkdir $dstdir
}
file copy $src $dst
# FIXA: update file info in tree too
$self SetNodeStatus $node equal
}
}
}
# React on double-click
method DoubleClick {W x y} {
foreach {W x y} [tablelist::convEventFields $W $x $y] break
set index [$tree index @$x,$y]
set node [$tree getfullkeys $index]
set lf [$tree rowattrib $node leftfull]
set rf [$tree rowattrib $node rightfull]
set type [$tree rowattrib $node type]
# On a file that exists on both sides, start a file diff
if {$type eq "file" && $lf ne "" && $rf ne ""} {
set PauseBgProcessing 1
newDiff $lf $rf
set PauseBgProcessing 0
# Stop the default bindings from running
return -code break
}
}
# React on Return key
method KeyReturn {} {
set node [$tree focus]
if {$node eq ""} return
set lf [$tree rowattrib $node leftfull]
set rf [$tree rowattrib $node rightfull]
set type [$tree rowattrib $node type]
# On a file that exists on both sides, start a file diff
if {$type eq "file" && $lf ne "" && $rf ne ""} {
set PauseBgProcessing 1
newDiff $lf $rf
set PauseBgProcessing 0
# Stop the default bindings from running
return -code break
}
}
# Bring up a context menu on a file.
method ContextMenu {W x y X Y} {
foreach {W x y} [tablelist::convEventFields $W $x $y] break
set index [$tree index @$x,$y]
set node [$tree getfullkeys $index]
set col [$tree columnindex @$x,$y]
set colname [$tree columncget $col -name]
set lf [$tree rowattrib $node leftfull]
set rf [$tree rowattrib $node rightfull]
set type [$tree rowattrib $node type]
set oneside [expr {($lf ne "") ^ ($rf ne "")}]
set m $win.popup
destroy $m
menu $m
if {$colname eq "structure"} {
$m add command -label "Prune equal" -command [mymethod PruneEqual]
$m add command -label "Prune empty" -command [mymethod PruneEmpty]
$m add command -label "Prune alone" -command [mymethod PruneAlone]
$m add command -label "Expand all" -command [mymethod OpenAll]
$m add command -label "Collapse all" -command [mymethod OpenAll 0]
}
if {$type eq "file" && $lf ne "" && $rf ne ""} {
# Files, both exist
$m add command -label "Compare Files" -command [list \
newDiff $lf $rf]
}
if {$type eq "directory"} {
if {$lf ne "" && $rf ne ""} {
# Directory, both exist
$m add command -label "Go down" -command [mymethod \
newTopDir $lf $rf]
}
if {$lf ne ""} {
# Directory, left exist
$m add command -label "Go down left" -command \
[mymethod newTopDir $lf ""]
if {$rf eq ""} {
# Only left exist
$m add command -label "Create Dir right" -command \
[mymethod CreateDir $node right]
}
}
if {$rf ne ""} {
# Directory, right exist
$m add command -label "Go down right" -command \
[mymethod newTopDir "" $rf]
if {$lf eq ""} {
# Only right exist
$m add command -label "Create Dir left" -command \
[mymethod CreateDir $node left]
}
}
}
if {$type eq "file"} {
if {([string match left* $colname] || $oneside) && $lf ne ""} {
if { ! [dict get $protect right]} {
$m add command -label "Copy File to Right" \
-command [mymethod CopyFile $node left]
}
$m add command -label "Edit Left File" \
-command [list EditFile $lf]
$m add command -label "Mark Left File" \
-command [list set [myvar leftMark] $lf]
if {$rightMark != ""} {
$m add command -label "Compare Left with $rightMark" \
-command [list newDiff $lf $rightMark]
}
} elseif {([string match right* $colname] || $oneside) && $rf ne ""} {
if { ! [dict get $protect left]} {
$m add command -label "Copy File to Left" \
-command [mymethod CopyFile $node right]
}
$m add command -label "Edit Right File" \
-command [list EditFile $rf]
$m add command -label "Mark Right File" \
-command [list set [myvar rightMark] $rf]
if {$leftMark != ""} {
$m add command -label "Compare Right with $leftMark" \
-command [list newDiff $leftMark $rf]
}
}
}
if {[string match left* $colname] && ![dict get $protect left]} {
$m add command -label "Protect Left Side" \
-command [mymethod ProtectSide left]
} elseif {[string match right* $colname] && ![dict get $protect right]} {
$m add command -label "Protect Right Side" \
-command [mymethod ProtectSide right]
}
tk_popup $m $X $Y
}
# Mark one side as protected and disable all copy buttons
method ProtectSide {side} {
variable widgets
dict set protect $side 1
foreach w [dict get $widgets $side] {
if {[winfo exists $w]} {
$w configure -state disabled
}
}
dict set widgets $side {}
}
method AddNodeToIdle {node {first 0}} {
if {[info exists IdleQueueArr($node)]} { return }
if {$first} {
# Items are popped from the end, so last is first
lappend IdleQueue $node
} else {
# Avoid compiled linsert by having index in a variable
set c0 0
set IdleQueue [linsert $IdleQueue[set IdleQueue {}] $c0 $node]
}
set IdleQueueArr($node) 1
if {$AfterId eq ""} {
set AfterId [after $AfterTime [mymethod UpdateIdle]]
}
}
# Debug logging
method Dlog {args} {
if {$DebugCh ne ""} {
set msg [join $args]
set now [clock clicks -milliseconds]
set suffix ""
if {[dict exists $DebugTime $msg]} {
set delta [expr {$now - [dict get $DebugTime $msg]}]
set suffix " (+$delta)"
}
dict set DebugTime $msg $now
puts $DebugCh "$now $msg$suffix"
flush $DebugCh
}
}
method DlogTablelist {} {
puts DlogTablelist
foreach cmd [info commands ::tablelist::*] {
set tail [namespace tail $cmd]
#if {[string match *SubCmd $tail]} continue
if {$tail in {
synchronize
tablelistWidgetCmd cleanupWindow getTablelistPath
handleMotion handleMotionDelayed
rowIndex isInteger keyToRow colIndex
}} continue
trace add execution $cmd enter [mymethod Dlog]
puts "Traced $cmd"
}
}
method UpdateIdle {} {
##nagelfar vartype tree _obj,tablelist
$self Dlog UpdateIdle
set AfterId "X"
if {$PauseBgProcessing} {
$self Dlog Pause
set AfterId [after 200 [mymethod UpdateIdle]]
return
}
set pre [clock clicks -milliseconds]
set errors {}
set count 0
while {[llength $IdleQueue] > 0} {
set node [lindex $IdleQueue end]
# Always make a pause before a large file
if {[$tree rowattrib $node type] ne "directory"} {
if {[$tree rowattrib $node largefile]} {
if {$count > 0} {
$self Dlog "New Lap for large file"
break
}
}
}
incr count
set IdleQueue [lrange $IdleQueue[set IdleQueue {}] 0 end-1]
unset IdleQueueArr($node)
if {[$tree rowattrib $node type] ne "directory"} {
set sts [catch {$self UpdateFileNode $node} err]
} else {
set sts [catch {$self UpdateDirNode $node} err]
}
if {$sts} {
lappend errors $node $err
break
}
# Work for at least 200 ms to keep things efficient
set post [clock clicks -milliseconds]
#puts "$pre $post [expr {$post - $pre}]"
if {($post - $pre) > $WorkTime} break
}
#if {($post - $pre) > 1000} {
#puts "[expr $post - $pre] ms for [$tree set $node leftfull]"
#}
# Update the status variable to track progress
if {$options(-statusvar) ne ""} {
upvar \#0 $options(-statusvar) statusvar
}
if {[llength $errors] > 0} {
lassign $errors node err
set leftfull [$tree rowattrib $node leftfull]
set rightfull [$tree rowattrib $node rightfull]
set answer [tk_messageBox -icon error -type abortretryignore \
-message \
"Error comparing\n$leftfull\nvs\n$rightfull:\n$err"]
if {$answer eq "retry"} {
$self AddNodeToIdle $node
} elseif {$answer eq "ignore"} {
# Do nothing, just continue
} else {
set statusvar ""
set AfterId ""
return
}
}
if {[llength $IdleQueue] > 0} {
set node [lindex $IdleQueue end]
set leftfull [$tree rowattrib $node "leftfull"]
set rightfull [$tree rowattrib $node "rightfull"]
if {$leftfull ne ""} {
set statusvar "$leftfull ($count)"
} else {
set statusvar "$rightfull ($count)"
}
$self Dlog Reschedule
set AfterId [after $AfterTime [mymethod UpdateIdle]]
} else {
$self Dlog DONE
set statusvar ""
set AfterId ""
}
}
method SetNodeStatus {node status} {
variable color
set old $NodeStatus($node)
if {$old eq $status} return
set NodeStatus($node) $status
$tree rowconfigure $node -foreground $color($status) \
-selectforeground $color($status)
#puts "Set [$tree item $node -text] to $status"
# Loop through children to update parent
set parent [$tree parentkey $node]
if {$parent eq "" || $parent eq "root"} { return }
# If this is only present on one side, there is no need to update
set lf [$tree rowattrib $parent leftfull]
set rf [$tree rowattrib $parent rightfull]
if {$lf eq "" || $rf eq ""} { return }
# If parent is being filled, do not update yet
if {$NodeStatus($parent) eq "unknown2"} {
return
}
set pstatus equal
foreach child [$tree childkeys $parent] {
set status $NodeStatus($child)
switch $status {
unknown - unknown2 {
set pstatus unknown
}
new - old - change {
set pstatus change
break
}
}
}
$self SetNodeStatus $parent $pstatus
}
method UpdateDirNode {node} {
if {[$tree rowattrib $node type] ne "directory"} {
return
}
if {$NodeStatus($node) ne "empty"} {
#puts "Dir [$tree set $node leftfull] already done"
return
}
$tree delete [$tree childkeys $node]
set leftfull [$tree rowattrib $node leftfull]
set rightfull [$tree rowattrib $node rightfull]
#$self Dlog "UpdateDirNode $leftfull"
if {$options(-bepa)} {
if {$leftfull eq ""} {
$self SetNodeStatus $node new
return
}
if {$rightfull eq ""} {
$self SetNodeStatus $node old
return
}
}
$self CompareDirs $leftfull $rightfull $node
}
method UpdateFileNode {node} {
set leftfull [$tree rowattrib $node leftfull]
set rightfull [$tree rowattrib $node rightfull]
#$self Dlog "UpdateFileNode $leftfull"
# If a -changelist is given, some higher level optimisation has already
# figured out what has changed, so the processing time can be cut down.
if {[llength $options(-changelist)]} {
if {$rightfull ni $options(-changelist)} {
#puts "$rightfull equal since not in change list"
$self SetNodeStatus $node equal
return
}
#puts "$rightfull checked since in change list"
}
set equal [CompareFiles $leftfull $rightfull]
if {$equal} {
$self SetNodeStatus $node "equal"
} else {
$self SetNodeStatus $node change
}
}
# List files under a directory node
# Returns status for the new node
method ListFiles {df1 df2 node} {
if {[catch {file lstat $df1 stat1}]} {
set size1 ""
set time1 ""
set type1 ""
} else {
set size1 $stat1(size)
set time1 [FormatDate $stat1(mtime)]
set type1 $stat1(type)
}
if {[catch {file lstat $df2 stat2}]} {
set size2 ""
set time2 ""
set type2 ""
} else {
set size2 $stat2(size)
set time2 [FormatDate $stat2(mtime)]
set type2 $stat2(type)
}
if {$df1 ne ""} {
set type $type1
set name [file tail $df1]
} else {
set type $type2
set name [file tail $df2]
}
set largeFile 0
if {$type eq "directory"} {
set values [list $name/ \
"" "" \
"" \
"" ""]
} else {
set values [list $name \
$size1 $time1 \
"" \
$size2 $time2]
# TODO: Configurable large file value?
if {$size1 > 1000000 && $size2 > 1000000} {
set largeFile 1
}
}
set id [$tree insertchild $node end $values]
$tree rowattrib $id "type" $type
set NodeStatus($id) unknown
$tree rowattrib $id leftfull $df1
$tree rowattrib $id rightfull $df2
$tree rowattrib $id largefile $largeFile
if {$type ne "directory"} {
if {$type eq "link"} {
$tree cellconfigure $id,structure -image $::img(link)
} else {
$tree cellconfigure $id,structure -image $::img(file)
$tree cellconfigure $id,command -window [mymethod addCmdCol]
}
}
if {$type eq "directory"} {
## Make it so that this node is openable
$tree collapse $id
$self SetNodeStatus $id empty
$self AddNodeToIdle $id 1
} elseif {$size1 == ""} {
$self SetNodeStatus $id new
} elseif {$size2 == ""} {
$self SetNodeStatus $id old
} else {
$self SetNodeStatus $id unknown
$self AddNodeToIdle $id
}
return $NodeStatus($id)
}
method addCmdCol {tbl row col w} {
variable widgets
set key [$tree getfullkeys $row]
set status $NodeStatus($key)
set type [$tree rowattrib $row type]
set lf [$tree rowattrib $row leftfull]
set rf [$tree rowattrib $row rightfull]
set bg [$tbl cget -background]
ttk::style configure Apa.TFrame -background $bg
ttk::style configure Apa.My.Toolbutton -background $bg
ttk::frame $w -style Apa.TFrame
ttk::button $w.bl -image $::img(left) -style Apa.My.Toolbutton \
-command [mymethod CopyFile $key right]
ttk::button $w.br -image $::img(right) -style Apa.My.Toolbutton \
-command [mymethod CopyFile $key left]
pack $w.bl $w.br -side left -fill y
# Store widgets names
dict lappend widgets left $w.bl
dict lappend widgets right $w.br
if {$lf eq ""} {
$w.br configure -state disabled
}
if {$rf eq ""} {
$w.bl configure -state disabled
}
}
# Compare two directories.
method CompareDirs {dir1 dir2 node} {
if {$dir1 eq ""} {
set files1 {}
} else {
set files1 [DirContents $dir1]
}
if {$dir2 eq ""} {
set files2 {}
} else {
set files2 [DirContents $dir2]
}
set len1 [llength $files1]
set len2 [llength $files2]
# Unknown2 is used to mark a directory filling up
$self SetNodeStatus $node unknown2
set p1 0
set p2 0
set status_change 0
set status_unknown 0
while 1 {
if {$p1 < $len1 && $p2 < $len2} {
set df1 [lindex $files1 $p1]
set f1 [file tail $df1]
set df2 [lindex $files2 $p2]
set f2 [file tail $df2]
set apa [FStrCmp $f1 $f2]
if {$apa == 0} {
# Equal names, separate them if not the same type
set apa [expr {- [FileIsDirectory $df1] \
+ [FileIsDirectory $df2]}]
}
switch -- $apa {
0 {
set sts [$self ListFiles $df1 $df2 $node]
incr p1
incr p2
if {$sts eq "unknown"} {
set status_unknown 1
}
}
-1 {
$self ListFiles $df1 "" $node
incr p1
set status_change 1
}
1 {
$self ListFiles "" $df2 $node
incr p2
set status_change 1
}
}
} elseif {$p1 < $len1 && $p2 >= $len2} {
set df1 [lindex $files1 $p1]
$self ListFiles $df1 "" $node
incr p1
set status_change 1
} elseif {$p1 >= $len1 && $p2 < $len2} {
set df2 [lindex $files2 $p2]
$self ListFiles "" $df2 $node
incr p2
set status_change 1
} else {
break
}
}
if {$dir1 eq ""} {
set status new
} elseif {$dir2 eq ""} {
set status old
} elseif {$status_change} {
set status change
} elseif {$status_unknown} {
set status unknown
} else {
set status equal
}
$self SetNodeStatus $node $status
}
}
snit::widget DirDiff {
hulltype toplevel
widgetclass Toplevel
component tree
variable statusVar
delegate option -norun to tree
delegate option -bepa to tree
constructor {args} {
eskilRegisterToplevel $win
wm title $win "Eskil Dir"
wm protocol $win WM_DELETE_WINDOW [list cleanupAndExit $win]
install tree using DirCompareTree $win.dc \
-leftdirvariable ::dirdiff(leftDir) \
-rightdirvariable ::dirdiff(rightDir) \
-statusvar [myvar statusVar]
$self configurelist $args
if {[info exists ::dirdiff(localChanges)]} {
$tree configure -changelist $::dirdiff(localChanges)
}
ttk::frame $win.fe1
ttk::frame $win.fe2
# Need to do this manually with snit
$hull configure -menu $win.m
psmenu::psmenu $win -top $win {
"&File" {
"C&ompare" -cmd "[mymethod DoDirCompare]" -acc "Alt-c"
---
"&Close" -cmd "cleanupAndExit $win"
---
"&Quit" -cmd "cleanupAndExit all"
}
"&Preferences" {
"Prefs..." -cmd makeDirDiffPrefWin
"Check" {
_Radio -var ::Pref(dir,comparelevel) {
"Do not check contents" -value 0
"Normal compare" -value 1
"Exact compare" -value 2
}
"Ignore \$Keyword:\$" -var ::Pref(dir,ignorekey)
}
"P&lugins..." -cmd "editPrefPlugins $win 1"
"Nice" {
_Radio -var ::Pref(dir,nice) -cmd "[mymethod DoNice]" {
1 50 100 1000
}
}
---
"Save default" -cmd "saveOptions $win"
}
"&Tools" {
"&New Diff Window" -cmd makeDiffWin
"&Clip Diff" -cmd makeClipDiffWin
if {$::tcl_platform(platform) eq "windows"} {
if { ! [catch {package require registry}]} {
---
"Setup &Registry" -cmd makeRegistryWin
}
}
}
"&Help" {
"&Tutorial" -cmd makeTutorialWin
"&About" -cmd makeAboutWin
}
if {$::eskil(debug)} {
"&Debug" {
if {$::tcl_platform(platform) eq "windows"} {
"Console" -var consolestate \
-onvalue show -offvalue hide -cmd "console \\$consolestate"
---
}
"&Reread Source" -cmd {EskilRereadSource}
---
"Redraw Window" -cmd {makeDirDiffWin}
}
}
}
ttk::button $win.bu -image $::img(upup) -command [mymethod UpDir] \
-underline 0
addBalloon $win.bu "Up in both."
bind $win <Alt-u> "$win.bu invoke"
#catch {font delete myfont}
#font create myfont -family $::Pref(fontfamily) -size $::Pref(fontsize)
ttk::entryX $win.e1 -textvariable dirdiff(leftDir) -width 30
ttk::button $win.bu1 -image $::img(up) -command [mymethod UpDir 1]
addBalloon $win.bu1 "Up in left."
ttk::button $win.bb1 -image $::img(browse) \
-command "[list BrowseDir "dirdiff(leftDir)" $win.e1]
[mymethod DoDirCompare]"
addBalloon $win.bb1 "Browse left."
after 50 [list after idle [list $win.e1 xview end]]
ttk::entryX $win.e2 -textvariable dirdiff(rightDir) -width 30
ttk::button $win.bu2 -image $::img(up) -command [mymethod UpDir 2]
addBalloon $win.bu2 "Up in right."
ttk::button $win.bb2 -image $::img(browse) \
-command "[list BrowseDir "dirdiff(rightDir)" $win.e2]
[mymethod DoDirCompare]"
addBalloon $win.bb2 "Browse right."
after 50 [list after idle [list $win.e2 xview end]]
bind $win.e1 <Return> [mymethod DoDirCompare]
bind $win.e2 <Return> [mymethod DoDirCompare]
ttk::label $win.sl -anchor w -textvariable [myvar statusVar]
pack $win.bb1 $win.bu1 -in $win.fe1 -side left -pady 1 -ipadx 10
pack $win.bu1 -padx 6
pack $win.e1 -in $win.fe1 -side left -fill x -expand 1
pack $win.bb2 $win.bu2 -in $win.fe2 -side right -pady 1 -ipadx 10
pack $win.bu2 -padx 6
pack $win.e2 -in $win.fe2 -side left -fill x -expand 1
grid $win.fe1 $win.bu $win.fe2 -sticky we
grid $tree - - -sticky news
grid $win.sl - - -sticky we
grid $win.bu -padx 6 -ipadx 15
grid rowconfigure $win 1 -weight 1
grid columnconfigure $win {0 2} -weight 1
}
method DoDirCompare {} {
# Reconfiguring the dirdiff widget triggers a rerun
$tree configure -leftdirvariable ::dirdiff(leftDir) \
-rightdirvariable ::dirdiff(rightDir)
}
method DoNice {} {
##nagelfar vartype tree _obj,tablelist
$tree nice $::Pref(dir,nice)
}
# Go up one level in directory hierarchy.
# 0 = both
method UpDir {{n 0}} {
global dirdiff
switch $n {
0 {
set dirdiff(leftDir) [file dirname $dirdiff(leftDir)]
set dirdiff(rightDir) [file dirname $dirdiff(rightDir)]
$win.e1 xview end
$win.e2 xview end
}
1 {
set dirdiff(leftDir) [file dirname $dirdiff(leftDir)]
$win.e1 xview end
}
2 {
set dirdiff(rightDir) [file dirname $dirdiff(rightDir)]
$win.e2 xview end
}
}
$self DoDirCompare
}
}
# Transfer preferences from dialog to real settings
proc ApplyDirDiffPref {} {
foreach item {
dir,comparelevel
dir,ignorekey
dir,onlyrev
} {
set ::Pref($item) $::TmpPref($item)
}
# Handle preferences that must be a list
foreach item {
dir,incfiles
dir,exfiles
dir,incdirs
dir,exdirs
} {
# Force a split to make sure the list is valid
if {[catch {llength $::TmpPref($item)}]} {
set ::TmpPref($item) [regexp -all -inline {\S+} $::TmpPref($item)]
}
set ::Pref($item) $::TmpPref($item)
}
}
# Create directory diff preferences window.
proc makeDirDiffPrefWin {} {
set top .dirdiffprefs
if {[winfo exists $top] && [winfo toplevel $top] eq $top} {
raise $top
focus -force $top
return
} else {
destroy $top
toplevel $top -padx 3 -pady 3
foreach item {
dir,comparelevel
dir,ignorekey
dir,incfiles
dir,exfiles
dir,incdirs
dir,exdirs
dir,onlyrev
} {
set ::TmpPref($item) $::Pref($item)
}
}
wm title $top "Eskil Directory Preferences"
set check [ttk::labelframe $top.check -text "Check" -padding 3]
ttk::radiobutton $check.rb1 -variable ::TmpPref(dir,comparelevel) -value 0 \
-text "Do not check contents"
ttk::radiobutton $check.rb2 -variable ::TmpPref(dir,comparelevel) -value 1 \
-text "Normal compare"
ttk::radiobutton $check.rb3 -variable ::TmpPref(dir,comparelevel) -value 2 \
-text "Exact compare"
grid $check.rb1 -sticky w -padx 3 -pady 3
grid $check.rb2 -sticky w -padx 3 -pady 3
grid $check.rb3 -sticky w -padx 3 -pady 3
grid columnconfigure $check {0 1 2} -uniform a -weight 1
set opts [ttk::labelframe $top.opts -text "Options" -padding 3]
ttk::checkbutton $opts.cb1 -variable ::TmpPref(dir,ignorekey) \
-text "Ignore \$Keyword:\$"
pack {*}[winfo children $opts] -side "top" -anchor w
set filter [ttk::labelframe $top.filter -text "Filter" -padding 3]
ttk::label $filter.l1 -text "Include Files" -anchor w
ttk::entryX $filter.e1 -width 20 -textvariable ::TmpPref(dir,incfiles)
ttk::label $filter.l2 -text "Exclude Files" -anchor w
ttk::entryX $filter.e2 -width 20 -textvariable ::TmpPref(dir,exfiles)
ttk::label $filter.l3 -text "Include Dirs" -anchor w
ttk::entryX $filter.e3 -width 20 -textvariable ::TmpPref(dir,incdirs)
ttk::label $filter.l4 -text "Exclude Dirs" -anchor w
ttk::entryX $filter.e4 -width 20 -textvariable ::TmpPref(dir,exdirs)
ttk::checkbutton $filter.cb1 -text "Only revision controlled" \
-variable ::TmpPref(dir,onlyrev)
grid $filter.l1 $filter.e1 -sticky we -padx 3 -pady 3
grid $filter.l2 $filter.e2 -sticky we -padx 3 -pady 3
grid $filter.l3 $filter.e3 -sticky we -padx 3 -pady 3
grid $filter.l4 $filter.e4 -sticky we -padx 3 -pady 3
grid $filter.cb1 - -sticky w -padx 3 -pady 3
grid columnconfigure $filter 1 -weight 1
set fb [ttk::frame $top.fb -padding 3]
ttk::button $fb.ok -width 10 -text "Ok" \
-command "ApplyDirDiffPref ; destroy $top"
ttk::button $fb.ap -width 10 -text "Apply" -command ApplyDirDiffPref
ttk::button $fb.ca -width 10 -text "Cancel" -command "destroy $top"
grid $fb.ok $fb.ap $fb.ca -padx 3 -pady 3
grid columnconfigure $fb {0 1 2} -uniform a -weight 1
pack $fb -side bottom -fill x
pack $check $opts $filter -side "top" -fill x
}
# Experimental...
#preprocess filter pa namnen sa man kan jamfora bibliotek
#med andrade namn.
proc makeRegSubWin {} {
set top .ddregsub
if {[winfo exists $top] && [winfo toplevel $top] eq $top} {
raise $top
focus -force $top
return
} else {
destroy $top
toplevel $top
}
wm title $top "Eskil Dir Preprocess"
ttk::entryX $top.e1 -textvariable ::dirdiff(pattern) -width 15
ttk::entryX $top.e2 -textvariable ::dirdiff(replace) -width 15
ttk::label $top.l1 -text "Pattern" -anchor w
ttk::label $top.l2 -text "Subst" -anchor w
grid $top.l1 $top.e1 -sticky we
grid $top.l2 $top.e2 -sticky we
grid columnconfigure $top 1 -weight 1
grid rowconfigure $top 2 -weight 1
}
proc makeDirDiffWin {{noautodiff 0}} {
if { ! [info exists ::dirdiff(leftDir)]} {
set ::dirdiff(leftDir) ""
}
if { ! [info exists ::dirdiff(rightDir)]} {
set ::dirdiff(rightDir) ""
}
# TODO, multi plugin for dirdiff?
set ::eskil(.dirdiff,plugin,1) ""
foreach {item val} $::eskil(defaultopts) {
set ::eskil(.dirdiff,$item) $val
}
# Support -r for directory diff
set revs {}
array set opts $::eskil(defaultopts)
if {[info exists opts(doptrev1)] && $opts(doptrev1) ne ""} {
lappend revs $opts(doptrev1)
}
if {[info exists opts(doptrev2)] && $opts(doptrev2) ne ""} {
lappend revs $opts(doptrev2)
}
# TODO: Trigger this on DirDiff, so a rerun can do it, and maybe have rev
# GUI fields
if {$::dirdiff(leftDir) eq $::dirdiff(rightDir) &&
$::dirdiff(leftDir) ne "" && ![string match *.kit $::dirdiff(leftDir)]} {
set fullname $::dirdiff(leftDir)
set type [detectRevSystem $fullname]
# Is this a revision system with dirdiff support?
if {[info commands eskil::rev::${type}::mount] ne ""} {
# No -r given; fall back on current.
if {[llength $revs] == 0} {
# Optimisation attempt for checkout vs latest, see if there
# is a command to detect local changes
if {[info commands eskil::rev::${type}::localChanges] ne ""} {
set ::dirdiff(localChanges) \
[eskil::rev::${type}::localChanges $fullname]
}
# Any vcs with dirdiff support should know that _ means current
set revs _
}
set revs [eskil::rev::${type}::ParseRevs $fullname $revs]
set rev1 [lindex $revs 0]
set rev2 [lindex $revs 1]
# A little "splash-screen" to show progress
destroy .dirdiffX
toplevel .dirdiffX
wm title .dirdiffX "Eskil Dir Diff"
label .dirdiffX.l1 -text "Collecting $type info for rev $rev1..."
label .dirdiffX.l2 -text ""
pack .dirdiffX.l1 .dirdiffX.l2 -side top -fill x
update
if {[catch {eskil::rev::${type}::mount $fullname $rev1} d1]} {
destroy .dirdiffX
tk_messageBox -icon error -message $d1 -type ok
# Can ony reach this from command line, so safe to exit
exit
}
set ::dirdiff(leftDir) $d1
if {$rev2 ne ""} {
.dirdiffX.l2 configure -text "and rev $rev2..."
update
set d2 [eskil::rev::${type}::mount $fullname $rev2]
set ::dirdiff(rightDir) $d2
}
destroy .dirdiffX
}
}
destroy .dirdiff
# TODO: better name for experimental parameter, propagate to cmd line
DirDiff .dirdiff -norun $noautodiff -bepa 1
return .dirdiff
}