bgCopy

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 :-)

# Module: bgCopy.tcl
# Stand : 11.10.2018
# 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>?
     #   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 {}]
          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]]]
          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 args} {
          variable activeCopies
          catch {
             close $in
             close $out
          }
          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])"
   }
   foreach {src dst} $argv {
      catch {bgCopy::bgCopySchedule $src $dst -mkdir 0 -exitcmd reportResult -force 1 -limit 3 -idlecmd {step hugo}} reslt
      puts $reslt
   }
   bgCopy::bgCopyWaitAll
   puts "fertig!"
}