#----------------------------------------------------------------------
# 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 {l} {
lsort -dictionary $l
}
# 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 [expr {$::eskil(.dirdiff,plugin) ne "" && \
[dict get $::eskil(.dirdiff,pluginpinfo) dir]}]
set ignorekey $::Pref(dir,ignorekey)
# Different size is enough when doing binary compare
if {$stat1(size) != $stat2(size) && $::Pref(dir,comparelevel) == 2 \
&& !$ignorekey && !$anyPlugin} {
return 0
}
# Same size and time is always considered equal
if {$stat1(size) == $stat2(size) && $stat1(mtime) == $stat2(mtime)} {
return 1
}
# 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) eval \
[list array set ::Pref [array get ::Pref]]
$::eskil(.dirdiff,plugin) eval [list set ::argv $::eskil(argv)]
interp share {} $ch1 $::eskil(.dirdiff,plugin)
interp share {} $ch2 $::eskil(.dirdiff,plugin)
set info1 [dict create name $file1 size $stat1(size)]
set info2 [dict create name $file2 size $stat2(size)]
set eq [$::eskil(.dirdiff,plugin) eval \
[list FileCompare $ch1 $ch2 $info1 $info2]]
set allow [dict get $::eskil(.dirdiff,pluginpinfo) allow]
if {$allow} {
$::eskil(.dirdiff,plugin) eval close $ch1
$::eskil(.dirdiff,plugin) eval close $ch2
} else {
$::eskil(.dirdiff,plugin) invokehidden close $ch1
$::eskil(.dirdiff,plugin) 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 {![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 {![string equal $f1 $f2]} {
set eq 0
}
}
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)
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 ""
variable AfterId ""
variable PauseBgProcessing 0
variable ScheduledRestart 0
variable AfterTime 1
variable IdleQueue {}
variable IdleQueueArr
variable leftMark ""
variable rightMark ""
variable leftDir ""
variable rightDir ""
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
}
set AfterId ""
set IdleQueue {}
set ScheduledRestart 0
array unset IdleQueueArr
# 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
$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 [$tree rowattrib $node status]
if {$status eq "equal"} {
$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
}
}
# Copy a file from one directory to the other
method CopyFile {node from} {
global dirdiff
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 {$from eq "left"} {
set src $lf
if {$rf ne ""} {
set dst $rf
} elseif {$rp ne ""} {
set dst [file join $rp [file tail $src]]
} else {
return
}
} elseif {$from eq "right"} {
set src $rf
if {$lf ne ""} {
set dst $lf
} elseif {$lp ne ""} {
set dst [file join $lp [file tail $src]]
} else {
return
}
} else {
error "Bad from argument to CopyFile: $from"
}
if {[file exists $dst]} {
if {[tk_messageBox -icon question -title "Overwrite file?" -message \
"Copy\n$src\noverwriting\n$dst ?" -type yesno] eq "yes"} {
file copy -force $src $dst
# FIXA: update file info in tree too
$self SetNodeStatus $node equal
}
} else {
if {[tk_messageBox -icon question -title "Copy file?" -message \
"Copy\n$src\nto\n$dst ?" -type yesno] eq "yes"} {
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 node [$tree index @$x,$y]
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 node [$tree index @$x,$y]
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 "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 ne ""} {
# Directory, right exist
$m add command -label "Go down right" -command [mymethod \
newTopDir "" $rf]
}
}
if {$type eq "file"} {
if {([string match left* $colname] || $oneside) && $lf ne ""} {
$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 ""} {
$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]
}
}
}
tk_popup $m $X $Y
}
method AddNodeToIdle {node} {
if {[info exists IdleQueueArr($node)]} { return }
lappend IdleQueue $node
set IdleQueueArr($node) 1
if {$AfterId eq ""} {
set AfterId [after $AfterTime [mymethod UpdateIdle]]
}
}
method UpdateIdle {} {
set AfterId "X"
if {$PauseBgProcessing} {
set AfterId [after 200 [mymethod UpdateIdle]]
return
}
set pre [clock clicks -milliseconds]
set errors {}
while {[llength $IdleQueue] > 0} {
set node [lindex $IdleQueue 0]
set IdleQueue [lrange $IdleQueue 1 end]
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 20 ms to keep things efficient
set post [clock clicks -milliseconds]
if {($post - $pre) > 20} 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 leftfull [$tree rowattrib $node leftfull]
set rightfull [$tree rowattrib $node rightfull]
if {$leftfull ne ""} {
set statusvar $leftfull
} else {
set statusvar $rightfull
}
set AfterId [after $AfterTime [mymethod UpdateIdle]]
} else {
set statusvar ""
set AfterId ""
}
}
method SetNodeStatus {node status} {
variable color
set old [$tree rowattrib $node status]
if {$old eq $status} return
$tree rowattrib $node status $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 {[$tree rowattrib $parent status] eq "unknown2"} {
return
}
set pstatus equal
foreach child [$tree childkeys $parent] {
set status [$tree rowattrib $child status]
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 {[$tree rowattrib $node status] 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 CompareDirs $leftfull $rightfull $node
}
method UpdateFileNode {node} {
set leftfull [$tree rowattrib $node leftfull]
set rightfull [$tree rowattrib $node rightfull]
# 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 stat $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 stat $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]
}
if {$type eq "directory"} {
set values [list $name \
"" "" \
"" \
"" ""]
} else {
set values [list $name \
$size1 $time1 \
"" \
$size2 $time2]
}
set id [$tree insertchild $node end $values]
$tree rowattrib $id type $type
$tree rowattrib $id status unknown
$tree rowattrib $id leftfull $df1
$tree rowattrib $id rightfull $df2
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
#$tree insertchild $id end dummy ;# a dummy
$tree cellconfigure $id,structure -text $name/
$self SetNodeStatus $id empty
$self AddNodeToIdle $id
$tree cellconfigure $id,structure -image $::img(clsd)
} elseif {$size1 == $size2 && \
$time1 == $time2} {
$self SetNodeStatus $id equal
} elseif {$size1 == ""} {
$self SetNodeStatus $id new
} elseif {$size2 == ""} {
$self SetNodeStatus $id old
} else {
$self SetNodeStatus $id unknown
$self AddNodeToIdle $id
}
return [$tree rowattrib $id status]
}
method addCmdCol {tbl row col w} {
set key [$tree getfullkeys $row]
set status [$tree rowattrib $row status]
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
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
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]
if {[info exists ::dirdiff(localChanges)]} {
$tree configure -changelist $::dirdiff(localChanges)
}
ttk::frame $win.fe1
ttk::frame $win.fe2
menu $win.m
$hull configure -menu $win.m
$win.m add cascade -menu $win.m.mf -label "File" -underline 0
menu $win.m.mf
$win.m.mf add command -label "Compare" -underline 1 \
-command [mymethod DoDirCompare] -accelerator "Alt-c"
bind $win <Alt-c> [mymethod DoDirCompare]
$win.m.mf add separator
$win.m.mf add command -label "Close" -underline 0 \
-command [list cleanupAndExit $win]
$win.m.mf add separator
$win.m.mf add command -label "Quit" -underline 0 \
-command [list cleanupAndExit all]
$win.m add cascade -menu $win.m.mo -label "Preferences" -underline 0
menu $win.m.mo
$win.m.mo add command -label "Prefs..." -command makeDirDiffPrefWin
$win.m.mo add cascade -label "Check" -menu $win.m.mo.mc
menu $win.m.mo.mc
$win.m.mo.mc add radiobutton -variable ::Pref(dir,comparelevel) -value 0 \
-label "Do not check contents"
$win.m.mo.mc add radiobutton -variable ::Pref(dir,comparelevel) -value 1 \
-label "Normal compare"
$win.m.mo.mc add radiobutton -variable ::Pref(dir,comparelevel) -value 2 \
-label "Exact compare"
$win.m.mo.mc add checkbutton -variable ::Pref(dir,ignorekey) \
-label "Ignore \$Keyword:\$"
$win.m.mo add command -label "Plugins..." -underline 1 \
-command [list EditPrefPlugins $win 1]
$win.m.mo add cascade -label "Nice" -menu $win.m.mo.mn
menu $win.m.mo.mn
$win.m.mo.mn add radiobutton -variable ::Pref(dir,nice) -value 1 \
-command [mymethod DoNice] -label 1
$win.m.mo.mn add radiobutton -variable ::Pref(dir,nice) -value 50 \
-command [mymethod DoNice] -label 50
$win.m.mo.mn add radiobutton -variable ::Pref(dir,nice) -value 100 \
-command [mymethod DoNice] -label 100
$win.m.mo.mn add radiobutton -variable ::Pref(dir,nice) -value 1000 \
-command [mymethod DoNice] -label 1000
$win.m.mo add separator
$win.m.mo add command -label "Save default" \
-command [list saveOptions $win]
$win.m add cascade -label "Tools" -underline 0 -menu $win.m.mt
menu $win.m.mt
$win.m.mt add command -label "New Diff Window" -underline 0 \
-command makeDiffWin
$win.m.mt add command -label "Clip Diff" -underline 0 \
-command makeClipDiffWin
if {$::tcl_platform(platform) eq "windows"} {
if {![catch {package require registry}]} {
$win.m.mt add separator
$win.m.mt add command -label "Setup Registry" -underline 6 \
-command makeRegistryWin
}
}
$win.m add cascade -label "Help" -underline 0 -menu $win.m.help
menu $win.m.help
$win.m.help add command -label "Tutorial" -command makeTutorialWin \
-underline 0
$win.m.help add command -label "About" -command makeAboutWin -underline 0
if {$::eskil(debug)} {
$win.m add cascade -label "Debug" -menu $win.m.md -underline 0
menu $win.m.md
if {$::tcl_platform(platform) eq "windows"} {
$win.m.md add checkbutton -label "Console" -variable consolestate \
-onvalue show -offvalue hide -command {console $consolestate}
$win.m.md add separator
}
$win.m.md add command -label "Reread Source" -underline 0 \
-command {EskilRereadSource}
$win.m.md add separator
$win.m.md add command -label "Redraw Window" -command {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 {} {
$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 {} {
if {![info exists ::dirdiff(leftDir)]} {
set ::dirdiff(leftDir) ""
}
if {![info exists ::dirdiff(rightDir)]} {
set ::dirdiff(rightDir) ""
}
set ::eskil(.dirdiff,plugin) ""
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 ""} {
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
DirDiff .dirdiff
return .dirdiff
}