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