#!/bin/tclsh
#
#
# Performance testing
#
# Parallel Differential backup utility
#
#  4x-10x faster that disk/mkfs.
#  2x faster i/o than fcp
# Usage:
#	bkup.tcl srcdir dstdir ?maxtasks? additional_mount_points ...
#
#
# BUGS:
#   Doesn't create directories in dstdir
#   Does not copy/rename
#	Won't overwrite files that don't have write permission
#	Probably does not report errors in copy operations
#
# April 2020
#      That guy with the hair
#
#
if {[llength $argv] == 0} {
	puts "usage: src-dir dst-dir ?max-tasks?" 
	exit -1
}

set verbose 0

if {[lindex $argv 0 ] eq {-v} } {
	set verbose 1
	set argv [lrange $argv 1 end]
}
if {[llength $argv] < 2} {
	puts "usage: src-dir dst-dir ?max-tasks?" 
	exit -1
}

set sdir [lindex $argv 0]
set ddir [lindex $argv 1]
set _maxW [lindex $argv 2]

if {$_maxW eq {}} {set _maxW 8}

#
# Experimental use of multiple sockets to do copy.
# 
set extra [lrange $argv 3 end]


#
# leverage TCL pipe and event system to do operations concurrently
#
proc popen {cmd cback} {
	global cb

	set fd [open "|$cmd"]
    fconfigure $fd -blocking 0 -buffering none
    fileevent $fd read  "callback $fd $cback"
	lappend cb(fd) $fd
	set cb($fd) 1 
	set cb($fd,cback) $cback
	puts "Open $cmd"
	return $fd
}

set _srcdata {}
set _srcfiles [list]
set _dstdata {}
set _dstfiles [list]

#
# Handle basic socket i/o for all async i/o channels
#
proc callback {fd cback} {
	global cb
	if {[eof $fd]} {
		puts "Close $cback"
		fileevent $fd read {}
		close $fd
		set cb($fd) 0
		return {}
	}
	set data [read $fd]
	if {! [string length $data]} {return}
	if {[catch  {$cback $fd $data} err] } {
		puts "#error processing $cback $err $::errorInfo"
		fileevent $fd read {}
		close $fd
		set cb($fd) 0
	}
	list
}

set _tocpy [list]
#
# Compare file names we have recieved thus far and if match comapare time stamp
# If src is newer then fork a copy worker or just queue if already max workers
#
# The queuing should probably not happen here as it blocks processing of the walk i/o
#
proc merge {data array  } {
	upvar #0 $array fn
	upvar #0 _${array}data var
	upvar #0 _${array}files list
	global src dst
	global _srcfiles _dstfiles

	append var $data

	set pos [string last \n $var]
	if {$pos == -1} {return {}}

	set files [string range $var 0 $pos]
	set var [string range $var [incr pos] end]

	foreach xx [split $files \n] {
		set f  [lrange $xx 0 end-1]
		set tm [lindex $xx end]
		set fn($f) $tm
		lappend list $f
	}

	set newsrc {}

	foreach f $_srcfiles {
		set pos [lsearch -exact $_dstfiles $f]
		if {$pos == -1 } {
			lappend newsrc $f
			continue
		}
		set _dstfiles [lreplace $_dstfiles $pos $pos]
		if { $src($f) <= $dst($f) } {continue}
		queue $f
	}
	set _srcfiles $newsrc
	list
}

#
# For walker I/O, we just match up src with dst and then compare timestamp
#
proc rd_src {fd data} {	merge $data src ;# Probably a waste of time to merge on source files}
proc rd_dst {fd data} { merge $data dst}


set _workers {}
set _replies 0

#
# This handles the RC worker that does the copy. We could just fork cp but rc option allows us
# to add features such as creating directory and rename tmp file names et al.
#
proc rc_worker {fd data} {
	global _workers _wrk

	foreach cmd [split $data \n] {
	if { $cmd eq {@INIT} } {
		runqueue $fd
	}
	if { $cmd eq {@DONE} } {
		incr _wrk($fd) -1
		incr ::_replies
		runqueue $fd
	}
	}

	list
}


set _queued 0

#
# Queue file to copy or fork worker.
#
proc queue {f} {
	global _workers _wrk

	if {! [string length $f]} {
		puts "Bogus file name"
		return
	}
	lappend ::_tocpy $f
	incr ::_queued
	if { [llength $::_workers] < $::_maxW} {
		newWorker $f
		return
	}
	foreach fd $_workers {
		if {$_wrk($fd) > 0 } {continue}
		runqueue $fd 
		return {}
	}
#	puts "Queue $f"
	list
}

set _copied 0

set _chan 0

set chans [concat $ddir $extra]
#
#
# Worker copy setup command
# Experimental use of multiple mount points for destination
#
# These have to be setup with the 'srv' command to provide multiple connections to dst.
#
# (Note: Did not help my setup with copying to unix using u9fs as 9p server)
#
#
proc sendcp {fd f} {
	incr ::_wrk($fd)
	set chan [lindex $::chans [expr {[incr ::_chan] % [llength $::chans]} ]]
	puts $fd  "cp $::sdir/$f $chan/$f ; echo  @DONE"
	incr ::_copied
}

#
# Worker callback to find next file to copy
#
proc runqueue {fd} {
	global _workers _wrk _tocpy
	if {! [llength $_tocpy] && $_wrk($fd) == 0 } {
		fileevent $fd read {}
		close $fd
		set p [lsearch -exact $_workers $fd]
		set _workers [lreplace $_workers $p $p]
		return
	}
	if  {! [llength $_tocpy]} { incr ::stats(stall) 1; return}

	set f [lindex $_tocpy 0]
	set _tocpy [lrange $_tocpy 1 end]
	sendcp $fd $f
	incr ::stats($fd,cp)
#	puts "RunQ $fd $f #$_wrk($fd) left #[llength $_tocpy]"
	list
}

#
# Fork new worker by queue processing
#
proc newWorker {f} {
	global _workers _wrk _tocpy

	set rc [open "|rc -I" r+]
	fconfigure $rc -blocking 0 -buffering none
	fileevent $rc read  "callback $rc rc_worker"
	lappend ::_workers $rc
	set _wrk($rc) 0
	runqueue $rc
	list
}


#
# Main code
#
# (note this is not bytecoded as it is not in a proc
#
#

set stime [clock clicks -milli]

#
#
# Fork seperate I/O for walking src and dst to find file names and modification times
#
set pwd [pwd]
cd $sdir
popen "walk -fe pm . 2> /dev/null </dev/null" rd_src
cd $pwd
cd $ddir
popen "walk -fe pm . 2> /dev/null </dev/null" rd_dst
cd $pwd

puts "spawning upto $_maxW workers"

#
# Perform all I/O processing internally via TCL event mechanism
#
# When all I/O channels , tcl will error out as vwait would block forever.
#
# This could be prevented by detecting this condition and setting variable to cause 
# manual exit from vwait
#

catch {vwait walking}

#
# Print statistics of file copy operations
#
puts stderr "src files #[array size src]"
puts stderr "dst files #[array size dst]"

puts stderr "newer  # [llength $_tocpy]"
puts stderr  "missing # [llength $_dstfiles]"
puts stderr "copied  # $_copied files  of $_queued requested"
puts stderr "ignored # [llength $_srcfiles]"

set etime [clock clicks -milli]

puts stderr  "Backup took [expr $etime - $stime]ms"

# 
# I/O statistics for performance optimisation
#
# parray stats




# Thats all folks