iogt.test

来自「tcl是工具命令语言」· TEST 代码 · 共 953 行 · 第 1/2 页

# -*- tcl -*-
# Commands covered:  transform, and stacking in general
#
# This file contains a collection of tests for Giot
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 2000 Ajuba Solutions.
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
# 
# RCS: @(#) $Id: iogt.test,v 1.7 2002/07/04 15:46:55 andreas_kupries Exp $

if {[catch {package require tcltest 2.1}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2.1 required."
    return
}
namespace eval ::tcl::test::iogt {

    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::test
    namespace import ::tcltest::testConstraint

    testConstraint testchannel [llength [info commands testchannel]]

set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
} dummy]

# " capture coloring of quotes

set path(dummyout) [makeFile {} dummyout]

set path(__echo_srv__.tcl) [makeFile {
#!/usr/local/bin/tclsh
# -*- tcl -*-
# echo server
#
# arguments, options: port to listen on for connections.
#                     delay till echo of first block
#                     delay between blocks
#                     blocksize ...

set port   [lindex $argv 0]
set fdelay [lindex $argv 1]
set idelay [lindex $argv 2]
set bsizes [lrange $argv 3 end]
set c      0

proc newconn {sock rhost rport} {
    variable fdelay
    variable c
    incr   c
    variable c$c

    #puts stdout "C $sock $rhost $rport / $fdelay" ; flush stdout

    upvar 0 c$c conn
    set conn(after) {}
    set conn(state) 0
    set conn(size)  0
    set conn(data)  ""
    set conn(delay) $fdelay

    fileevent  $sock readable [list echoGet $c $sock]
    fconfigure $sock -translation binary -buffering none -blocking 0
}

proc echoGet {c sock} {
    variable fdelay
    variable c$c
    upvar 0 c$c conn

    if {[eof $sock]} {
	# one-shot echo
	exit
    }

    append conn(data) [read $sock]

    #puts stdout "G $c $sock $conn(data) <<$conn(data)>>" ; flush stdout

    if {$conn(after) == {}} {
	set conn(after) [after $conn(delay) [list echoPut $c $sock]]
    }
}

proc echoPut {c sock} {
    variable idelay
    variable fdelay
    variable bsizes
    variable c$c
    upvar 0 c$c conn

    if {[string length $conn(data)] == 0} {
	#puts stdout "C $c $sock" ; flush stdout
	# auto terminate
	close $sock
	exit
	#set conn(delay) $fdelay
	return
    }


    set conn(delay) $idelay

    set n [lindex $bsizes $conn(size)]

    #puts stdout "P $c $sock $n >>" ; flush stdout

    #puts __________________________________________
    #parray conn
    #puts n=<$n>


    if {[string length $conn(data)] >= $n} {
	puts -nonewline $sock [string range $conn(data) 0 $n]
	set conn(data) [string range $conn(data) [incr n] end]
    }

    incr conn(size)
    if {$conn(size) >= [llength $bsizes]} {
	set conn(size) [expr {[llength $bsizes]-1}]
    }

    set conn(after) [after $conn(delay) [list echoPut $c $sock]]
}

#fileevent stdin readable {exit ;#cut}

# main
socket -server newconn $port
vwait forever
} __echo_srv__.tcl]


########################################################################

proc fevent {fdelay idelay blocks script data} {
    # start and initialize an echo server, prepare data
    # transmission, then hand over to the test script.
    # this has to start real transmission via 'flush'.
    # The server is stopped after completion of the test.

    # fixed port, not so good. lets hope for the best, for now.
    set port 4000

    eval exec tclsh __echo_srv__.tcl \
	    $port $fdelay $idelay $blocks >@stdout &

    after 500

    #puts stdout "> $port" ; flush stdout

    set         sk [socket localhost $port]
    fconfigure $sk           \
	    -blocking   0    \
	    -buffering  full \
	    -buffersize [expr {10+[llength $data]}]

    puts -nonewline $sk $data

    # The channel is prepared to go off.

    #puts stdout ">>>>>" ; flush stdout

    uplevel #0 set sock $sk
    set res [uplevel #0 $script]

    catch {close $sk}
    return $res
}

# --------------------------------------------------------------
# utility transformations ...

proc id {op data} {
    switch -- $op {
	create/write -
	create/read  -
	delete/write -
	delete/read  -
	clear_read   {;#ignore}
	flush/write -
	flush/read  -
	write       -
	read        {
	    return $data
	}
	query/maxRead {return -1}
    }
}

proc id_optrail {var op data} {
    variable $var
    upvar 0 $var trail

    lappend trail $op

    switch -- $op {
	create/write	-	create/read	-
	delete/write	-	delete/read	-
	flush/read	-
	clear/read	{ #ignore }
	flush/write	-
	write		-
	read		{
	    return $data
	}
	query/maxRead	{
	    return -1
	}
	default		{
	    lappend trail "error $op"
	    error $op
	}
    }
}


proc id_fulltrail {var op data} {
    variable $var
    upvar 0 $var trail

    #puts stdout ">> $var $op $data" ; flush stdout

    switch -- $op {
	create/write -	create/read  -
	delete/write -	delete/read  -
	clear_read   {
	    set res *ignored*
	}
	flush/write -	flush/read  -
	write       -
	read        {
	    set res $data
	}
	query/maxRead {
	    set res -1
	}
    }

    #catch {puts stdout "\t>* $res" ; flush stdout}
    #catch {puts stdout "x$res"} msg

    lappend trail [list $op $data $res]
    return $res
}

proc counter {var op data} {
    variable $var
    upvar 0 $var n

    switch -- $op {
	create/write -	create/read  -
	delete/write -	delete/read  -
	clear_read   {;#ignore}
	flush/write  -	flush/read   {return {}}
	write {
	    return $data
	}
	read  {
	    if {$n > 0} {
		incr n -[string length $data]
		if {$n < 0} {
		    set n 0
		}
	    }
	    return $data
	}
	query/maxRead {
	    return $n
	}
    }
}


proc counter_audit {var vtrail op data} {
    variable $var
    variable $vtrail
    upvar 0 $var n $vtrail trail

    switch -- $op {
	create/write -	create/read  -
	delete/write -	delete/read  -
	clear_read   {
	    set res {}
	}
	flush/write  -	flush/read   {
	    set res {}
	}
	write {
	    set res $data
	}
	read  {
	    if {$n > 0} {
		incr n -[string length $data]
		if {$n < 0} {
		    set n 0
		}
	    }
	    set res $data
	}
	query/maxRead {
	    set res $n
	}
    }

    lappend trail [list counter:$op $data $res]
    return $res
}


proc rblocks {var vtrail n op data} {
    variable $var
    variable $vtrail
    upvar 0 $var buf $vtrail trail

    set res {}

    switch -- $op {
	create/write -	create/read  -
	delete/write -	delete/read  -
	clear_read   {
	    set buf {}
	}
	flush/write {
	}
	flush/read  {
	    set res $buf
	    set buf {}
	}
	write       {
	    set data
	}
	read        {
	    append buf $data

	    set b [expr {$n * ([string length $buf] / $n)}]

	    append op " $n [string length $buf] :- $b"

	    set res [string range $buf 0 [incr b -1]]
	    set buf [string range $buf [incr b] end]
	    #return $res
	}
	query/maxRead {
	    set res -1
	}
    }

    lappend trail [list rblock | $op $data $res | $buf]
    return $res
}


# --------------------------------------------------------------
# ... and convenience procedures to stack them

proc identity {-attach channel} {
    testchannel transform $channel -command [namespace code id]
}

proc audit_ops {var -attach channel} {
    testchannel transform $channel -command [namespace code [list id_optrail $var]]
}

proc audit_flow {var -attach channel} {
    testchannel transform $channel -command [namespace code [list id_fulltrail $var]]
}

proc stopafter {var n -attach channel} {
    variable $var
    upvar 0 $var vn
    set vn $n
    testchannel transform $channel -command [namespace code [list counter $var]]
}

proc stopafter_audit {var trail n -attach channel} {
    variable $var
    upvar 0 $var vn
    set vn $n
    testchannel transform $channel -command [namespace code [list counter_audit $var $trail]]
}

proc rblocks_t {var trail n -attach channel} {
    testchannel transform $channel -command [namespace code [list rblocks $var $trail $n]]
}

# --------------------------------------------------------------
# serialize an array, with keys in sorted order.

proc array_sget {v} {
    upvar $v a

    set res [list]
    foreach n [lsort [array names a]] {
	lappend res $n $a($n)
    }
    set res
}

proc asort {alist} {
    # sort a list of key/value pairs by key, removes duplicates too.

    array set  a $alist
    array_sget a
}

########################################################################

test iogt-1.1 {stack/unstack} testchannel {
    set fh [open $path(dummy) r]
    identity -attach $fh
    testchannel unstack $fh
    close   $fh
} {}

test iogt-1.2 {stack/close} testchannel {
    set fh [open $path(dummy) r]
    identity -attach $fh
    close   $fh
} {}

test iogt-1.3 {stack/unstack, configuration, options} testchannel {
    set fh [open $path(dummy) r]
    set ca [asort [fconfigure $fh]]
    identity -attach $fh
    set cb [asort [fconfigure $fh]]
    testchannel unstack $fh
    set cc [asort [fconfigure $fh]]
    close $fh

    # With this system none of the buffering, translation and
    # encoding option may change their values with channels
    # stacked upon each other or not.

    # cb == ca == cc

    list [string equal $ca $cb] [string equal $cb $cc] [string equal $ca $cc]
} {1 1 1}

test iogt-1.4 {stack/unstack, configuration} testchannel {
    set fh [open $path(dummy) r]
    set ca [asort [fconfigure $fh]]
    identity -attach $fh
    fconfigure $fh \
	    -buffering   line \
	    -translation cr   \
	    -encoding    shiftjis
    testchannel unstack $fh
    set cc [asort [fconfigure $fh]]

    set res [list \
	    [string equal $ca $cc]   \
	    [fconfigure $fh -buffering]  \
	    [fconfigure $fh -translation] \
	    [fconfigure $fh -encoding]    \
	    ]

    close $fh
    set res
} {0 line cr shiftjis}

test iogt-2.0 {basic I/O going through transform} testchannel {
    set fin  [open $path(dummy)    r]
    set fout [open $path(dummyout) w]

    identity -attach $fin
    identity -attach $fout

    fcopy $fin $fout

    close $fin
    close $fout