Version 1 of bgCopy

Updated 2018-10-10 23:51:35 by MHo

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
bgCopy::bgCopySchedule sourcefile2 destfile2
bgCopy::bgCopySchedule sourcefile3 destfile3
bgCopy::bgCopyWaitAll; # <---- eventloop is needed
########################################################################################################################
# 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!"
}