The idea behind this module is to parallelize several file copies to possibly save time. Instead of this:
file copy sourcefile1 destfile1 file copy sourcefile2 destfile2 file copy sourcefile3 destfile3
one can use something like this:
bgCopy::bgCopySchedule sourcefile1 destfile1; # Scheduling one copy... bgCopy::bgCopySchedule sourcefile2 destfile2; # ...and a second... bgCopy::bgCopySchedule sourcefile3 destfile3; # ...and third bgCopy::bgCopyWaitAll; # <---- eventloop is needed. This runs until all copies are done.
There are several limitations cmpared to file copy. If it's really faster to copy many files via the eventloop in the background instead of doing it sequentially needs to be approved. Perhaps its only really fast to do it with multiple threads (thread pool) or multiple external processes...
But it was an evening fun project :-)
MHo, 2019-05-23:
#######################################################################################################################
# Module: bgCopy.tcl
# Stand : 11.10.2018, 27.12.2018, 23.05.2019
# Autor : Matthias Hoffmann
# Zweck : Ein Wrapper für fcopy
#
namespace eval bgCopy {
package require Tcl 8.6; # try
variable activeCopies 0
variable allCopies 0
#####
# Initiiert einen Kopiervorgang
# Argumente: Eingabedatei Ausgabedatei
# ?-mkdir 1? ?-force 1? ?-exitcmd <befehl>? ?-limit <n>? ?-idlecmd <befehl>? ?-srctime 1? ?-move 1?
# Was passiert bei Dingen wie 'Diskfull', 'I/O-Error'? -> bgerror!
#
proc bgCopySchedule {src dst args} {
variable activeCopies
variable allCopies
variable options [dict create -mkdir 0 -force 0 -exitcmd {} -limit 0 -idlecmd {} -srctime 0 -move 0]
set keys [dict keys $options]
# später in Library auslagern
foreach {arg val} $args {
set key [lsearch -glob -nocase -inline $keys $arg*]
if {$key ne ""} {
dict set options $key $val
} else {
return -code error "invalid option $arg. Allowed are: $keys"
}
}
if {[dict get $options -force] == 0 && [file exists $dst]} {
return -code error "destination exists: $dst"
}
set dstDir [file dirname $dst]
if {![file isdirectory $dstDir] && [dict get $options -mkdir]} {
# Directory nicht vorhanden, oder ist eine Datei -> versuchen, anzulegen,
# wenn dies eingestellt ist
file mkdir $dstDir; # nicht anlegbar, als Datei vorhanden -> propagieren
}
set out [open $dst wb]; # brummt auf, wenn z.B. dir nicht da, keine Rechte etc.
try {
set in [open $src rb]
} on error {result options} {
close $out; # war schon geöffnet -> schliessen
return -options $options $result; # repropagate error
}
# Resource-Bremse; ACHTUNG: Files sind schon geöffnet!
while {[dict get $options -limit] > 0 && $activeCopies >= [dict get $options -limit]} {
bgCopyWaitOne
}
fcopy $in $out -command [namespace code [list bgCopyClose $src $dst $in $out \
[dict get $options -exitcmd]\
[dict get $options -srctime]\
[dict get $options -move]]]
incr activeCopies
incr allCopies; # := handle
return [list $activeCopies $allCopies $src $in $dst $out]
}
#####
# Generischer Callback; Wird aufgerufen mit Abschluss des Hintergrund-Kopierens.
# Ruft, wenn definiert, den benutzerdefinierten Handler -exitcmd.
# schlecht:
# "If either inchan or outchan get closed while the copy is in progress, the current
# copy is stopped and the command callback is NOT made."
#
proc bgCopyClose {src dst in out exitcmd srctime move args} {
variable activeCopies
catch {
close $in
close $out
if {$srctime == 1} {
file mtime $dst [file mtime $src]
}
if {$move == 1} {
file delete -force -- $src; # simuliert ren, bleibt aber ein Copy
}
}
incr activeCopies -1
if {[llength $exitcmd]} {
catch {uplevel 1 [list {*}$exitcmd $src $dst {*}$args]}; # Fehler hier ignorieren!
}
}
#####
# Wartet, bis EIN Kopiervorgang abgeschlossen ist
# Optional für den Aufrufer, fall dieser eigene while{}-Schleife aufbaut.
# Ein mit -idlecmd definierter Handler wird zuvor aufgerufen.
#
proc bgCopyWaitOne {} {
variable options
if {[llength [dict get $options -idlecmd]]} {
catch {uplevel 1 [list {*}[dict get $options -idlecmd]]}; # Fehler hier ignorieren!
}
vwait bgCopy::activeCopies
}
#####
# Wartet, bis ALLE Kopiervorgäge abgeschlossen sind
# Ein mit -idlecmd definierter Handler wird vor jedem Kopierabschluss aufgerufen.
#
proc bgCopyWaitAll {} {
variable activeCopies
while {$activeCopies > 0} {
bgCopyWaitOne
}
}
#####
# Liefert für den Aufrufer die Anzahl aktiver Kopiervorgänge
# (erspart direkten Zugriff auf die Variable)
#
proc bgCopyActiveCopies {} {
variable activeCopies
return $activeCopies
}
package provide bgCopy 0.1
}
#
# Tests
#
if {[info exists argv0] && [file tail [info script]] eq [file tail $argv0]} {
proc reportResult {args} {
puts "reportResult-Callback: $args (aktiv: [bgCopy::bgCopyActiveCopies])"
}
proc step {args} {
puts "step-Callback: $args (aktiv: [bgCopy::bgCopyActiveCopies])"
}
set r [time {
foreach {src dst} $argv {
# catch {bgCopy::bgCopySchedule $src $dst -mkdir 0 -exitcmd reportResult -force 1 -limit 3 -idlecmd {step hugo}} reslt
catch {bgCopy::bgCopySchedule $src $dst -mkdir 0 -force 1 -limit 2 -srctime 1 -move 1} reslt
# puts $reslt
}
bgCopy::bgCopyWaitAll
# puts "fertig!"
exit; #####
} 10]
puts $r
# Vergleichsmessung 1
set r [time {
foreach {src dst} $argv {
catch {file copy -force -- $src $dst} reslt
# puts $reslt
}
# puts "fertig!"
} 10]
puts $r
}