Tcl Source Code

Check-in [cdb6ed3f55]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:small amend (code review, implicit gets for *nix/eof to avoid endless event-cycle, etc)
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | sebres-speedup-testsuite
Files: files | file ages | folders
SHA3-256: cdb6ed3f55e4107fe8a47dbb71d998962d7b605d069f168559fba3b998ec109b
User & Date: sebres 2018-12-18 22:30:55.640
Context
2018-12-18
22:30
small amend (code review, implicit gets for *nix/eof to avoid endless event-cycle, etc) Leaf check-in: cdb6ed3f55 user: sebres tags: sebres-speedup-testsuite
20:41
tests: new test-command "testisprocessrunning" in order to help recognize in test cases a child proc... check-in: 21737c5c85 user: sebres tags: sebres-speedup-testsuite
Changes
Unified Diff Ignore Whitespace Patch
Changes to tests/socket.test.
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622

1623

1624
1625
1626
1627




1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647

1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
		} else {
		    set x {client socket was inherited}
		}
	    } else {
		set x {client socket was not inherited}
	    }
	    # touch to signal end:
	    set done $done
	    catch { close $file }
	} else {
	    set x {impossible case}
	    catch { close $file }
	    set done -2
	}
	return
    }
    proc scriptend {p} {
	# wait for end of p:
	variable pid2
	variable done

	set time 100

	if {![eof $p]} {
	    if {[info command ::testisprocessrunning] eq ""
	     || [testisprocessrunning $pid2]
	    } {




		return
	    }
	    set time 0; # process exited - notify immediately
	}
	fileevent $p readable {}
	# Pipe closed - process exited, give few time (0.1s) to fulfill the end.
	after $time [list set done 1]
	# If the socket doesn't hit end-of-file in 0.1 seconds, the
	# script1 process must have inherited the client.
	close $p
    }

    set done 0

    # Launch the script2 process with port as argument
    set port [lindex [fconfigure $server -sockname] 2]
    set pid1 {}
    set p [open "|[list [interpreter] $path(script2) $port]" w+]
    set pid2 [pid $p]
    fconfigure $p -buffering none -blocking 0

    fileevent $p readable [list scriptend $p]

    set x none
    set tmr [after 2000 {set done -1; set x timeout}]
    vwait done
    if {[info command ::testisprocessrunning] ne ""} {
    	# be sure process 2 is exited:
	while {$done == 0 && [testisprocessrunning $pid2]} {
	    after 10; update
	}
	# and process 1 is still running:
	if {$done >= 0 && $pid1 ne "" && ![testisprocessrunning $pid1]} {
	    set x {unexpected, process 2 exited}
	}







|












>

>




>
>
>
>






|













>



|


|







1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
		} else {
		    set x {client socket was inherited}
		}
	    } else {
		set x {client socket was not inherited}
	    }
	    # touch to signal end:
	    after 0 [namespace code {set done $done}]
	    catch { close $file }
	} else {
	    set x {impossible case}
	    catch { close $file }
	    set done -2
	}
	return
    }
    proc scriptend {p} {
	# wait for end of p:
	variable pid2
	variable done
	variable waitcntr
	set time 100
	gets $p
	if {![eof $p]} {
	    if {[info command ::testisprocessrunning] eq ""
	     || [testisprocessrunning $pid2]
	    } {
		# avoid endless event-cycle if process "hangs" before eof signaled:
		if {[incr waitcntr] > 1000} {
		    fileevent $p readable {}
		}
		return
	    }
	    set time 0; # process exited - notify immediately
	}
	fileevent $p readable {}
	# Pipe closed - process exited, give few time (0.1s) to fulfill the end.
	after $time [namespace code {set done 1}]
	# If the socket doesn't hit end-of-file in 0.1 seconds, the
	# script1 process must have inherited the client.
	close $p
    }

    set done 0

    # Launch the script2 process with port as argument
    set port [lindex [fconfigure $server -sockname] 2]
    set pid1 {}
    set p [open "|[list [interpreter] $path(script2) $port]" w+]
    set pid2 [pid $p]
    fconfigure $p -buffering none -blocking 0
    set waitcntr 0
    fileevent $p readable [list scriptend $p]

    set x none
    set tmr [after 2000 [namespace code {set done -1; set x timeout}]]
    vwait done
    if {[info command ::testisprocessrunning] ne ""} {
	# be sure process 2 is exited:
	while {$done == 0 && [testisprocessrunning $pid2]} {
	    after 10; update
	}
	# and process 1 is still running:
	if {$done >= 0 && $pid1 ne "" && ![testisprocessrunning $pid1]} {
	    set x {unexpected, process 2 exited}
	}