# BEGIN_ICS_COPYRIGHT8 ****************************************
# 
# Copyright (c) 2015, Intel Corporation
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
# 
#     * Redistributions of source code must retain the above copyright notice,
#       this list of conditions and the following disclaimer.
#     * Redistributions in binary form must reproduce the above copyright
#       notice, this list of conditions and the following disclaimer in the
#       documentation and/or other materials provided with the distribution.
#     * Neither the name of Intel Corporation nor the names of its contributors
#       may be used to endorse or promote products derived from this software
#       without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
# 
# END_ICS_COPYRIGHT8   ****************************************

# [ICS VERSION STRING: unknown]

# low level process management routines

# This is the default stty settings for the pty used by expect
# to have it take effect callers of spawn or test_spawn must
# declare global stty_init in their function
# alternately they could declare a local variable with their own settings
# or take the default settings
global stty_init
# avoid surprise carriages returns in pty due to column wrap
set stty_init "columns 500"

global os_type
set os_type [ exec uname -s ]

proc stop_child { spawn_id_list { signal TERM }} {
##
## stop_child
## ----------
## stop the given set of child processes
##
## Usage:
##	stop_child spawn_id_list [signal]
## Arguments:
##	spawn_id_list - list of spawn id's from test_spawn
##	signal - signal to send to kill child if not already dead.
##		default is TERM

    global test_spawn_id_list test_spawn_program
    upvar #0 spawn_id global_spawn_id

    foreach spawn_id $spawn_id_list {
	# see if child still running
	if { [catch {set pid [exp_pid -i $spawn_id]}] == 1 } {
	    # child must already be dead
	    log_message "Child exited: $test_spawn_program($spawn_id)"
	} else {

	    log_message "Stopping $test_spawn_program($spawn_id)"
	    # terminate child
	    catch {exp_close -i $spawn_id }
	    if { "$signal" != "" } {
		catch {exec kill -s TERM $pid }
	    }
	}
	catch {exp_wait -i $spawn_id }
	set index [lsearch -exact $test_spawn_id_list $spawn_id]
	if { $index != -1 } {
	    set test_spawn_id_list [ lreplace $test_spawn_id_list $index $index ]
	}
	if { $spawn_id == $global_spawn_id } {
	    # so expect_after in test_suite looks at a valid
	    # value for spawn_id
	    set global_spawn_id {}
	}
    }
}

proc kill_child { spawn_id_list signal } {
##
## kill_child
## ----------
## send a signal to the given children
##
## Usage:
##	kill_child spawn_id_list [signal]
## Arguments:
##	spawn_id_list - list of spawn id's from test_spawn
##	signal - signal to send to child

    global test_spawn_program

    foreach spawn_id $spawn_id_list {
	if { [catch {set pid [exp_pid -i $spawn_id]}] == 1 } {
	    # child must already be dead
	    continue
	}
	log_message "Sending SIG$signal to $test_spawn_program($spawn_id)"
	catch {exec kill -s $signal $pid}
    }
}

proc wait_child { spawn_id_list } {
##
## wait_child
## ----------
## Wait for child to die, do not send any signals
##
## Usage:
##	wait_child spawn_id_list
## Arguments:
##	spawn_id_list - list of spawn id's from test_spawn

    stop_child $spawn_id_list ""
}

proc wait_child_eof { spawn_id_list timelimit { err_msg "timeout: waiting for data or EOF"} } {
##
## wait_child_eof
## --------------
## Wait for an eof from the given set of children and log all output
##
## Usage:
##	wait_child_eof spawn_id_list timelimit [ err_msg ]
## Arguments:
##	spawn_id_list - list of spawn ids to operate on
##	timelimit - maximum time to wait for eof per child
##		This timelimit is restarted each time the child provides output
##	err_msg - error to provide if timeout waiting for eof
##		default is "timeout: waiting for data or EOF"
## Additional Information:
##	The child is unconditionally stopped after the wait, even if
##	the wait fails.
##	The children are waited for sequentially, not in unison

    global expect_out

    # since our local spawn_id will not match the global one
    # expect_after will not get involved
    set_timeout $timelimit
    foreach spawn_id $spawn_id_list {
	set retcode [ catch { expect {
	    "?*"	{ exp_continue }
	    eof	noop
	    timeout	{ log_message "wait_child_eof: $err_msg"; error "wait_child_eof: $err_msg" }
	    default { log_message "wait_child_eof: default unexpected"
		error "wait_child_eof: default unexpected"
	    }
	}
	} res ]
	# make sure child terminates
	stop_child $spawn_id
	if { $retcode != 0 } {
	    error $res $res
	}
    }
}

proc wait_eof { timelimit } \
{
##
## wait_eof
## --------
## utility procedure to wait for eof
##
## Usage:
##	wait_eof timelimit
## Arguments:
##	timelimit - maximum time to wait
## Returns:
##	nothing
##	timeout - error exception
## Additional Information:
##	This is designed for use within test_case's $code
##	It is similar to expect_eof/ignore_rest except that it
##	waits for eof from the spawned task and logs all messages
##	received until eof.  The only way it fails is if the child
##	does no output for $timeout and does not eof either.
##
##	The child is specified by the global variable spawn_id
##	The global timeout is changed

    global timeout
    global spawn_id
    global expect_out

    set_timeout $timelimit

    wait_child_eof $spawn_id $timeout
    return
}

proc child_cleanup { { show_output 1 } { id "" } } \
{
#
# child_cleanup
# -------------
# cleanup after child after test completion
#
# Usage:
#	child_cleanup [show_output] [id]
# Arguments:
#	show_output - should additional lines of child output be shown first
#	id - spawn_id of child to cleanup, default is global spawn_id
# Returns:
#	nothing
# Additional Information:
#	This makes sure that the child has exited or been killed
#	This routine is for internal use and is not documented for user use
#
#	The child is specified by the global variable spawn_id

    global lines_to_show
    global expecting

    if { "$id" == "" } {
	global spawn_id
	set id $spawn_id
	# so expect_after in test_suite looks at a valid
	# value for spawn_id
	set spawn_id {}
    } else {
	# use a local, expect_after isn't involved anyway
	# since we cover eof and default cases in show_more_lines
	set spawn_id $id
    }
    if { $show_output } {
	# show the next few lines
	if { [info exists lines_to_show] } {
	    set line_cnt $lines_to_show
	} else {
	    set line_cnt 10;	# default value
	}
	catch { show_more_lines $line_cnt $id }
    }

    set expecting ""

    stop_child $id
    return
}

global test_spawn_id_list
set test_spawn_id_list {}

proc test_spawn { program_name args } {
##
## test_spawn
## ----------
## spawn a child process for monitoring with send/expect
##
## Usage:
##	test_spawn program_name args
## Arguments:
##	program_name - name for child in log messages
##	args - expect spawn args for child creation, includes command name
## Additional Information:
##  spawn in run in callers context and $spawn_id will reflect new task
##	global stty_init can be used to accept the default global settings
##	if not declared the defaults are used, if local - overrides global default

    global test_spawn_id_list test_spawn_program
    global stty_init

    log_message "spawn $args"
    uplevel spawn $args
    upvar spawn_id new_spawn_id

    lappend test_spawn_id_list $new_spawn_id
    set test_spawn_program($new_spawn_id) $program_name
}


proc stop_all_children {} {
##
## stop_all_children
## -----------------
## stop all currently running children
##
## Usage:
##	stop_all_children
## Additional Information:
##	stop_child is run against all children started with test_spawn

    stop_child $test_spawn_id_list
}

proc cleanup_all_children { { show_output 1 } } {
##
## cleanup_all_children
## -------------
## cleanup after all children after test completion
##
## Usage:
##	cleanup_all_children [show_output]
## Arguments:
##	show_output - should next few lines of child output be logged
## Returns:
##	nothing
## Additional Information:
##	All children started with test_spawn are sequentially processed

    global test_spawn_id_list

    foreach id $test_spawn_id_list {
	child_cleanup $show_output $id
    }
}

#proc command_name { arg_list } {
#	# return first non-dash argument, used to parse spawn arg list
#	# to get name for program to operate on
#	foreach arg $arg_list {
#		if { [ string match "-*" $arg ] == 0 } {
#			return $arg
#		}
#	}
#	return "unknown_program"
#}

# later, if test_spawn_id_list has more than 1 element, show the corresponding
# element in the list when operate on it via send/expect

# fix all other tests to use test_spawn and cleanup_all_children
# instead of spawn and child_cleanup

# used to be needed for parallel below
# now fork/wait is exp_fork/exp_wait, kill is exec shell's kill
# we ignore errors, FastFabric on opteron sometimes finds 64 bit expect and
# 32 bit tclx library loaded, however on those systems expect seems to
# be able to run the desired fast fabric commands
#catch {
#	if { [ file exists /usr/lib/libtclx.so ] } {
#    	load /usr/lib/libtclx.so
#	} elseif { [ file exists /usr/lib64/tclx8.4/libtclx8.4.so ] } {
#    	load /usr/lib64/tclx8.4/libtclx8.4.so
#	}
#}

set qlgc_fork exp_fork
set qlgc_wait exp_wait
if { ! [ catch { set thread_tcl $tcl_platform(threaded) } result] } {
	# Our own TCL extension to work around fork issues
	#load /usr/lib/opa/tools/libqlgc_fork.so
	package require qlgc_fork
	set qlgc_fork qlgc_fork
	set qlgc_wait qlgc_wait
}

proc dump_file_to_output { fd } {
##
## dump_file_to_output
## -------------------
## Dumps output of file to stdout
##
## Usage:
##  dump_file_to_output $fd
## Arguments:
##  fd - File discriptor to be use for reading
## Returns:
##  nothing
##
	if { $fd == 0 } {
		return
	}
	while {1} {
		set line [gets $fd]
		if {[eof $fd]} {
			close $fd
			break
		}
		puts "$line"
	}
}

proc parallel { var list code } {
##
## parallel
## -------------
## execute code in parallel (one process per entry in list) with var
## set to each item in list
##
## Usage:
##	parallel var list code
## Arguments:
##	var - name of variable to be assigned a value from list
##	list - values for $var, one process per entry
##	code - code to execute, will be executed in stack frame of caller
## Returns:
##	nothing
## Additional Information:
##	Used TclX version of fork/wait, expect version can't wait for non-spawned
##	processes
##
##	This is intended for use within parallel execution of
##	test suites/cases/items
##	beware the sub-processes will have the same files/expect sessions open
##	generally it is a bad a item to have parallel processes sharing the
##	same expect session (reads from session could go to either process)
##	hooks with tools_ functions allow counters for run to be maintained
##	across the process boundaries and allow failures in sub-processes
##	to appropriately propigate up

    global env
    upvar $var $var
    global os_type
	global qlgc_fork
	global qlgc_wait
	global orig_stdout

    if {  [ test_parallel ] } {
	tools_clear_tmp_counters
	set max_parallel [test_get_env TEST_MAX_PARALLEL]
	set first 0
	set last [expr $max_parallel - 1]
	set ff_pid [pid]
	set test_serialize_output [test_check_yn [test_get_env TEST_SERIALIZE_OUTPUT]]

	while { $first < [llength $list] } {
	    set processes {}
		if { $test_serialize_output } {
			set child_counter 1
			array unset fd_list
		}
	    foreach $var [ lrange $list $first $last] {
		if { $test_serialize_output } {
			set fname "/tmp/qlgc_tmp_${ff_pid}_${child_counter}"
			set fd [open $fname w+]
		}
		set pid [ eval $qlgc_fork ]
		if { $pid == 0 } {
			# child process
			if { $test_serialize_output } {
				package require qlgc_fork
				if { $orig_stdout == "" } {
					set orig_stdout [qlgc_dup stdout]
					fconfigure $orig_stdout -buffering line
				}
				close stdout
				set fd [open $fname {WRONLY APPEND TRUNC} ]
				close stderr
				set fd1 [qlgc_dup stdout ]
				fconfigure $fd -buffering line
				fconfigure $fd1 -buffering line
				file delete $fname
			}
		    tools_clear_saved_counters
		    set errorcode [ catch { uplevel eval "{" "$code" "}" } errorinfo ]
		    tools_save_counters $errorcode $errorinfo
			if { $test_serialize_output } {
				close $fd
				close $fd1
				if { $orig_stdout != "" } {
					close $orig_stdout
				}
			}
		    exit 0
		} elseif { $pid == -1 } {
			if { $test_serialize_output } {
				close $fd
				file delete $fname
			}
		    fail_test "Unable to fork"
		} else {
			# parent process
		    lappend processes $pid
			if { $test_serialize_output } {
				set fd_list($pid) $fd
				incr child_counter
			}
		}
	    }
		if { $test_serialize_output } {
			wait_process_list $processes [array get fd_list]
		} else {
			wait_process_list $processes
		}
	    set first [expr $last + 1]
	    incr last $max_parallel
	}
	tools_propigate_process_results
    } else {
	foreach $var $list {
	    uplevel eval "{" "$code" "}"
	}
    }
}

proc wait_process_list { pid_list {fd_arr "" }} {
##
## wait_process_list
## -------------
## Internal helper function, waits for a set of processes to exit
## for each the tmp_counters are updated
## intended for use internal to parallel and wait_subprocesses

    global env
	global qlgc_fork
	global qlgc_wait

    set killed 0
	set test_serialize_output [test_check_yn [test_get_env TEST_SERIALIZE_OUTPUT]]

	if { $fd_arr != "" } {
		array set fd_list $fd_arr
	}

    foreach pid $pid_list {
	while { 1 } {
	    # wait on x86_64 is broken, does not actually wait
	    if { [ catch { set wait_status [ eval $qlgc_wait -i -1 ] } errorinfo ] } {
		sleep 1
		continue
	    }
	    # first element of wait_status list is PID
	    set pid [lindex $wait_status 0]
	    # check pid against list, could be a CHILDKILLED status
	    if { [ lsearch -exact $pid_list $pid ] == -1 } {
		# not found
		continue
	    }
	    # a process in pid_list has exited
	    break
	}
	# once we kill processes, we ignore the counters, they will have exited
	if { ! $killed } {
		tools_update_tmp_counters $pid
	} else {
		tools_remove_tmp_counters $pid
	}
	if { $test_serialize_output == 1 &&
		 $fd_arr != ""
		} {

			dump_file_to_output $fd_list($pid)
			set fd_list($pid) "0"
		}

	if { ! [ tools_check_process_results ] } {
		# we had a failure which will propigate up
		# stop other processes
	    	log_message "Child failure detected: killing $pid_list"
		log_message "exec: kill -s TERM $pid_list"
		if { $test_serialize_output == 1 &&
			$fd_arr != ""
			} {
			foreach {pid fd} [array get fd_list] {
				#This check ensures that we don't perform any output for
				#already completed children.
				if { $fd != 0 } {
					dump_file_to_output $fd
					set fd_list($pid) "0"
				}
			}
		}

		catch {exec kill -s TERM $pid_list }
		sleep 2
		log_message "exec: kill -s KILL $pid_list"
		catch {exec kill -s KILL $pid_list }
		set killed 1
	}
    }
}

global sub_process_list
set sub_process_list {}

proc init_subprocesses { } {
##
## init_subprocesses
## -------------
## prepare to start subprocesses
##
## Usage:
##	init_subprocesses
## Returns:
##	None
##
    global sub_process_list

    tools_clear_tmp_counters
}

proc subprocess { code } {
##
## subprocess
## -------------
## start a subprocess
##
## Usage:
##	subprocess code
## Arguments:
##	code - code to execute, will be executed in stack frame of caller
## Returns:
##	nothing
## Additional Information:
##	Used TclX version of fork/wait, expect version can't wait for non-spawned
##	processes
##
##	This is intended for use within tests where 2 or more processes will
##  be talking to eachother, such as a client/server application within
##	test suites/cases/items
##	beware the sub-processes will have the same files/expect sessions open
##	generally it is a bad a idea to have parallel processes sharing the
##	same expect session (reads from session could go to either process)
##
##	hooks with tools_ functions allow counters for run to be maintained
##	across the process boundaries and allow failures in sub-processes
##	to appropriately propigate up
##
##  After starting all subprocesses, parent process must call
##  wait_subprocesses (or fail_test)

    global sub_process_list
	global os_type
	global qlgc_fork
	global qlgc_wait

    set pid [ eval $qlgc_fork ]
    if { $pid == 0 } {
	tools_clear_saved_counters
	set errorcode [ catch { uplevel eval "{" "$code" "}" } errorinfo ]
	tools_save_counters $errorcode $errorinfo
	exit 0
    } elseif { $pid == -1 } {
	fail_test "Unable to fork"
    } else {
	lappend sub_process_list $pid
    }
}

proc wait_subprocesses { } {
##
## wait_subprocesses
## -------------
## wait for all the subprocesses started since last init_subprocesses
##
## Usage:
##	wait_subprocesses

    global sub_process_list

    set list $sub_process_list
    set sub_process_list {}
    wait_process_list $list
    tools_propigate_process_results
}