1# Synchronize two directory trees, VFS-aware 2# 3# Copyright (c) 1999 Matt Newman, Jean-Claude Wippler and Equi4 Software. 4 5# 6# Recursively sync two directory structures 7# 8proc rsync {arr src dest} { 9 #tclLog "rsync $src $dest" 10 upvar 1 $arr opts 11 12 if {$opts(-auto)} { 13 # Auto-mounter 14 vfs::auto $src -readonly 15 vfs::auto $dest 16 } 17 18 if {![file exists $src]} { 19 return -code error "source \"$src\" does not exist" 20 } 21 if {[file isfile $src]} { 22 #tclLog "copying file $src to $dest" 23 return [rcopy opts $src $dest] 24 } 25 if {![file isdirectory $dest]} { 26 #tclLog "copying non-file $src to $dest" 27 return [rcopy opts $src $dest] 28 } 29 set contents {} 30 eval lappend contents [glob -nocomplain -dir $src *] 31 eval lappend contents [glob -nocomplain -dir $src .*] 32 33 set count 0 ;# How many changes were needed 34 foreach file $contents { 35 #tclLog "Examining $file" 36 set tail [file tail $file] 37 if {$tail == "." || $tail == ".."} { 38 continue 39 } 40 set target [file join $dest $tail] 41 42 set seen($tail) 1 43 44 if {[info exists opts(ignore,$file)] || \ 45 [info exists opts(ignore,$tail)]} { 46 if {$opts(-verbose)} { 47 tclLog "skipping $file (ignored)" 48 } 49 continue 50 } 51 if {[file isdirectory $file]} { 52 incr count [rsync opts $file $target] 53 continue 54 } 55 if {[file exists $target]} { 56 #tclLog "target $target exists" 57 # Verify 58 file stat $file sb 59 file stat $target nsb 60 #tclLog "$file size=$sb(size)/$nsb(size), mtime=$sb(mtime)/$nsb(mtime)" 61 if {$sb(size) == $nsb(size)} { 62 # Copying across filesystems can yield a slight variance 63 # in mtime's (typ 1 sec) 64 if { ($sb(mtime) - $nsb(mtime)) < $opts(-mtime) } { 65 # Good 66 continue 67 } 68 } 69 #tclLog "size=$sb(size)/$nsb(size), mtime=$sb(mtime)/$nsb(mtime)" 70 } 71 incr count [rcopy opts $file $target] 72 } 73 # 74 # Handle stray files 75 # 76 if {$opts(-prune) == 0} { 77 return $count 78 } 79 set contents {} 80 eval lappend contents [glob -nocomplain -dir $dest *] 81 eval lappend contents [glob -nocomplain -dir $dest .*] 82 foreach file $contents { 83 set tail [file tail $file] 84 if {$tail == "." || $tail == ".."} { 85 continue 86 } 87 if {[info exists seen($tail)]} { 88 continue 89 } 90 rdelete opts $file 91 incr count 92 } 93 return $count 94} 95proc _rsync {arr args} { 96 upvar 1 $arr opts 97 #tclLog "_rsync $args ([array get opts])" 98 99 if {$opts(-show)} { 100 # Just show me, don't do it. 101 tclLog $args 102 return 103 } 104 if {$opts(-verbose)} { 105 tclLog $args 106 } 107 if {[catch { 108 eval $args 109 } err]} { 110 if {$opts(-noerror)} { 111 tclLog "Warning: $err" 112 } else { 113 return -code error -errorinfo ${::errorInfo} $err 114 } 115 } 116} 117 118# This procedure is better than just 'file copy' on Windows, 119# MacOS, where the source files probably have native eol's, 120# but the destination should have Tcl/unix native '\n' eols. 121# We therefore need to handle text vs non-text files differently. 122proc file_copy {src dest {textmode 0}} { 123 set mtime [file mtime $src] 124 if {!$textmode} { 125 file copy $src $dest 126 } else { 127 switch -- [file extension $src] { 128 ".tcl" - 129 ".txt" - 130 ".msg" - 131 ".test" - 132 ".itk" { 133 } 134 default { 135 if {[file tail $src] != "tclIndex"} { 136 # Other files are copied as binary 137 #return [file copy $src $dest] 138 file copy $src $dest 139 file mtime $dest $mtime 140 return 141 } 142 } 143 } 144 # These are all text files; make sure we get 145 # the translation right. Automatic eol 146 # translation should work fine. 147 set fin [open $src r] 148 set fout [open $dest w] 149 fcopy $fin $fout 150 close $fin 151 close $fout 152 } 153 file mtime $dest $mtime 154} 155 156proc rcopy {arr path dest} { 157 #tclLog "rcopy: $arr $path $dest" 158 upvar 1 $arr opts 159 # Recursive "file copy" 160 161 set tail [file tail $dest] 162 if {[info exists opts(ignore,$path)] || \ 163 [info exists opts(ignore,$tail)]} { 164 if {$opts(-verbose)} { 165 tclLog "skipping $path (ignored)" 166 } 167 return 0 168 } 169 global rsync_globs 170 foreach expr $rsync_globs { 171 if {[string match $expr $path]} { 172 if {$opts(-verbose)} { 173 tclLog "skipping $path (matched $expr) (ignored)" 174 } 175 return 0 176 } 177 } 178 if {![file isdirectory $path]} { 179 if {[file exists $dest]} { 180 _rsync opts file delete $dest 181 } 182 _rsync opts file_copy $path $dest $opts(-text) 183 return 1 184 } 185 set count 0 186 if {![file exists $dest]} { 187 _rsync opts file mkdir $dest 188 set count 1 189 } 190 set contents {} 191 eval lappend contents [glob -nocomplain -dir $path *] 192 eval lappend contents [glob -nocomplain -dir $path .*] 193 #tclLog "copying entire directory $path, containing $contents" 194 foreach file $contents { 195 set tail [file tail $file] 196 if {$tail == "." || $tail == ".."} { 197 continue 198 } 199 set target [file join $dest $tail] 200 incr count [rcopy opts $file $target] 201 } 202 return $count 203} 204proc rdelete {arr path} { 205 upvar 1 $arr opts 206 # Recursive "file delete" 207 if {![file isdirectory $path]} { 208 _rsync opts file delete $path 209 return 210 } 211 set contents {} 212 eval lappend contents [glob -nocomplain -dir $path *] 213 eval lappend contents [glob -nocomplain -dir $path .*] 214 foreach file $contents { 215 set tail [file tail $file] 216 if {$tail == "." || $tail == ".."} { 217 continue 218 } 219 rdelete opts $file 220 } 221 _rsync opts file delete $path 222} 223proc rignore {arr args} { 224 upvar 1 $arr opts 225 226 foreach file $args { 227 set opts(ignore,$file) 1 228 } 229} 230proc rpreserve {arr args} { 231 upvar 1 $arr opts 232 233 foreach file $args { 234 catch {unset opts(ignore,$file)} 235 } 236} 237proc rignore_globs {args} { 238 global rsync_globs 239 set rsync_globs $args 240} 241 242# 28-01-2003: changed -text default to 0, i.e. copy binary mode 243array set opts { 244 -prune 0 245 -verbose 1 246 -show 0 247 -ignore "" 248 -mtime 1 249 -compress 1 250 -auto 1 251 -noerror 1 252 -text 0 253} 254# 2005-08-30 only ignore the CVS subdir 255# 2007-03-29 added .svn as well 256# 2009-02-02 added .git 257#rignore opts CVS RCS core a.out 258rignore opts CVS .svn .git 259rignore_globs {} 260 261set USAGE "[file tail $argv0] ?options? src dest 262 263 Where options are:- 264 265 -auto 0|1 Auto-mount starkits (default: $opts(-auto)) 266 -compress 0|1 Enable MetaKit compression (default: $opts(-compress)) 267 -mtime n Acceptable difference in mtimes (default: $opts(-mtime)) 268 -prune 0|1 Remove extra files in dest (default: $opts(-prune)) 269 -show 0|1 Show what would be done, but don't do it (default: $opts(-show)) 270 -verbose 0|1 Show each file being processed (default: $opts(-verbose)) 271 -noerror 0|1 Continue processing after errors (default: $opts(-noerror)) 272 -ignore glob Pattern of files to ignore (default: CVS RCS core a.out) 273 -preserve glob Pattern of files not to ignore (i.e. to clear defaults) 274 -text 0|1 Copy .txt/tcl/msg/test/itk files as text (default: $opts(-text))" 275 276if {[llength $argv] < 2} { 277 puts stderr $USAGE 278 exit 1 279} 280 281while {[llength $argv] > 0} { 282 set arg [lindex $argv 0] 283 284 if {![string match -* $arg]} { 285 break 286 } 287 if {![info exists opts($arg)]} { 288 puts stderr "invalid option \"$arg\"\n$USAGE" 289 exit 1 290 } 291 if {$arg eq "-ignore"} { 292 rignore opts [lindex $argv 1] 293 } elseif {$arg eq "-preserve"} { 294 rpreserve opts [lindex $argv 1] 295 } else { 296 set opts($arg) [lindex $argv 1] 297 } 298 set argv [lrange $argv 2 end] 299} 300catch { 301package require vfs::mk4 302set vfs::mk4::compress $opts(-compress) 303} 304set src [lindex $argv 0] 305set dest [lindex $argv 1] 306# 307# Load up sync params (tcl script) 308# 309if {[file exists $src/.rsync]} { 310 upvar #0 opts cb 311 source $src/.rsync 312} 313# 314# Perform actual sync 315# 316 317set n [rsync opts $src $dest] 318 319puts stdout "$n updates applied" 320