Tcl Source Code

a filter and once as a normal method.
.PP
Each filter should decide for itself whether to permit the execution to go
forward to the proper implementation of the method (which it does by invoking
the \fBnext\fR command as filters are inserted into the front of the method
call chain) and is responsible for returning the result of \fBnext\fR.
.PP
Filters are invoked when processing an invokation of the \fBunknown\fR
method because of a failure to locate a method implementation, but \fInot\fR
when invoking either constructors or destructors. (Note however that the
\fBdestroy\fR method is a conventional method, and filters are invoked as
normal when it is called.)
.SH EXAMPLES
.PP
This example demonstrates how to use the \fBnext\fR command to call the
(super)class's implementation of a method. The script:
.PP
.CS
oo::class create theSuperclass {

Subject to the constraints imposed by the rules for matching the whole
RE, subexpressions also match the longest or shortest possible
substrings, based on their preferences, with subexpressions starting
earlier in the RE taking priority over ones starting later. Note that
outer subexpressions thus take priority over their component
subexpressions.
.PP
The quantifiers \fB{1,1}\fR and \fB{1,1}?\fR can be used to
force longest and shortest preference, respectively, on a
subexpression or a whole RE.
.RS
.PP
\fBNOTE:\fR This means that you can usually make a RE be non-greedy overall by
putting \fB{1,1}?\fR after one of the first non-constraint atoms or
parenthesized sub-expressions in it. \fIIt pays to experiment\fR with the
placing of this non-greediness override on a suitable range of input texts
when you are writing a RE if you are using this level of complexity.
.PP
For example, this regular expression is non-greedy, and will match the
shortest substring possible given that
.QW \fBabc\fR
will be matched as early as possible (the quantifier does not change that):
.PP
.CS
ab{1,1}?c.*x.*cba
.CE
.PP
The atom
.QW \fBa\fR
has no greediness preference, we explicitly give one for
.QW \fBb\fR ,
and the remaining quantifiers are overridden to be non-greedy by the preceding
non-greedy quantifier.
.RE
.PP
Match lengths are measured in characters, not collating elements. An
empty string is considered longer than no match at all. For example,
.QW \fBbb*\fR
matches the three middle characters of
.QW \fBabbbc\fR ,
.QW \fB(week|wee)(night|knights)\fR

	    Tcl_DecrRefCount(objPtr);
	    Tcl_DecrRefCount(listObj);
	    listObj = NULL;
	}
	valueTokenPtr = TokenAfter(valueTokenPtr);
    }
    if (listObj != NULL) {


	TclEmitPush(TclAddLiteralObj(envPtr, listObj, NULL), envPtr);











	return TCL_OK;
    }

    /*
     * Push the all values onto the stack.
     */

	pcAdjustment = 2;
	cleanup = opnd;
	DECACHE_STACK_INFO();
	iPtr->varFramePtr = framePtr->callerVarPtr;
	pc += pcAdjustment;
	TEBC_YIELD();

	TclPushTailcallPoint(interp);
	oPtr = contextPtr->oPtr;
	if (oPtr->flags & FILTER_HANDLING) {
	    TclNRAddCallback(interp, FinalizeOONextFilter,
		    framePtr, contextPtr, INT2PTR(contextPtr->index),
		    INT2PTR(contextPtr->skip));
	} else {
	    TclNRAddCallback(interp, FinalizeOONext,

	    }
	    TclOODeleteContext(contextPtr);
	    if (result != TCL_OK) {
		Tcl_DiscardInterpState(state);

		/*
		 * Take care to not delete a deleted object; that would be
		 * bad. [Bug 2903011] Also take care to make sure that we have
		 * the name of the command before we delete it. [Bug
		 * 9dd1bd7a74]
		 */

		if (!Deleted(oPtr)) {
		    (void) TclOOObjectName(interp, oPtr);
		    Tcl_DeleteCommandFromToken(interp, oPtr->command);
		}
		return NULL;
	    }
	    Tcl_RestoreInterpState(interp, state);
	}
    }

    }
    TclOODeleteContext(contextPtr);
    if (result != TCL_OK) {
	Tcl_DiscardInterpState(state);

	/*
	 * Take care to not delete a deleted object; that would be bad. [Bug
	 * 2903011] Also take care to make sure that we have the name of the
	 * command before we delete it. [Bug 9dd1bd7a74]
	 */

	if (!Deleted(oPtr)) {
	    (void) TclOOObjectName(interp, oPtr);
	    Tcl_DeleteCommandFromToken(interp, oPtr->command);
	}
	DelRef(oPtr);
	return TCL_ERROR;
    }
    Tcl_RestoreInterpState(interp, state);
    *objectPtr = (Tcl_Object) oPtr;

	set srvurl $url
	set targetAddr [list $phost $pport]
    } else {
	set targetAddr [list $host $port]
    }
    # Proxy connections aren't shared among different hosts.
    set state(socketinfo) $host:$port

    # Save the accept types at this point to prevent a race condition. [Bug
    # c11a51c482]
    set state(accept-types) $http(-accept)

    # See if we are supposed to use a previously opened channel.
    if {$state(-keepalive)} {
	variable socketmap
	if {[info exists socketmap($state(socketinfo))]} {
	    if {[catch {fconfigure $socketmap($state(socketinfo))}]} {
		Log "WARNING: socket for $state(socketinfo) was closed"

	    return -code error $err
	}
    }

    return $token
}

# http::Connected --
#
#	Callback used when the connection to the HTTP server is actually
#	established.
#
# Arguments:
#       token	State token.
#       proto	What protocol (http, https, etc.) was used to connect.
#	phost	Are we using keep-alive? Non-empty if yes.
#	srvurl	Service-local URL that we're requesting
# Results:
#	None.

proc http::Connected {token proto phost srvurl} {
    variable http
    variable urlTypes

    variable $token
    upvar 0 $token state

    # Set back the variables needed here

	set how $state(-method)
    }
    # We cannot handle chunked encodings with -handler, so force HTTP/1.0
    # until we can manage this.
    if {[info exists state(-handler)]} {
	set state(-protocol) 1.0
    }
    set accept_types_seen 0
    if {[catch {
	puts $sock "$how $srvurl HTTP/$state(-protocol)"

	if {[dict exists $state(-headers) Host]} {

	    # Allow Host spoofing. [Bug 928154]
	    puts $sock "Host: [dict get $state(-headers) Host]"
	} elseif {$port == $defport} {
	    # Don't add port in this case, to handle broken servers. [Bug
	    # #504508]
	    puts $sock "Host: $host"
	} else {
	    puts $sock "Host: $host:$port"
	}

	puts $sock "User-Agent: $http(-useragent)"
        if {$state(-protocol) == 1.0 && $state(-keepalive)} {
	    puts $sock "Connection: keep-alive"
        }
        if {$state(-protocol) > 1.0 && !$state(-keepalive)} {
	    puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1
        }
        if {[info exists phost] && ($phost ne "") && $state(-keepalive)} {
	    puts $sock "Proxy-Connection: Keep-Alive"
        }
        set accept_encoding_seen 0
	set content_type_seen 0
	dict for {key value} $state(-headers) {
	    set value [string map [list \n "" \r ""] $value]
	    set key [string map {" " -} [string trim $key]]
	    if {[string equal -nocase $key "host"]} {
		continue
	    }
	    if {[string equal -nocase $key "accept-encoding"]} {
		set accept_encoding_seen 1
	    }
	    if {[string equal -nocase $key "accept"]} {
		set accept_types_seen 1
	    }
	    if {[string equal -nocase $key "content-type"]} {
		set content_type_seen 1
	    }


	    if {[string equal -nocase $key "content-length"]} {
		set contDone 1
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $sock "$key: $value"
	    }
	}
	# Allow overriding the Accept header on a per-connection basis. Useful
	# for working with REST services. [Bug c11a51c482]
	if {!$accept_types_seen} {
	    puts $sock "Accept: $state(accept-types)"
	}
        if {!$accept_encoding_seen && ![info exists state(-handler)]} {
	    puts $sock "Accept-Encoding: gzip,deflate,compress"
        }
	if {$isQueryChannel && $state(querylength) == 0} {
	    # Try to determine size of data in channel. If we cannot seek, the
	    # surrounding catch will trap us

	# if state(status) is error, it means someone's already called Finish
	# to do the above-described clean up.
	if {$state(status) ne "error"} {
	    Finish $token $err
	}
    }

}

# Data access functions:
# Data - the URL data
# Status - the transaction status: ok, reset, eof, timeout
# Code - the HTTP transaction code, e.g., 200
# Size - the size of the URL data

    http::cleanup $t
} -result {ok {HTTP/1.0 200 Data follows}}
test http-3.13 {http::geturl socket leak test} {
    set chanCount [llength [file channels]]
    for {set i 0} {$i < 3} {incr i} {
	catch {http::geturl $badurl -timeout 5000}
    }

    # No extra channels should be taken
    expr {[llength [file channels]] == $chanCount}
} 1
test http-3.14 "http::geturl $fullurl" -body {
    set token [http::geturl $fullurl -validate 1]
    http::code $token
} -cleanup {

} -result {Content-Length Content-Type Date X-Check}
test http-3.27 {http::geturl: -headers override -type} -body {
    set token [http::geturl $url/headers -type "text/plain" -query dummy \
	    -headers [list "Content-Type" "text/plain;charset=utf-8"]]
    http::data $token
} -cleanup {
    http::cleanup $token
} -match regexp -result {(?n)Host .*

User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
Accept \*/\*
Accept-Encoding .*
Content-Length 5}
test http-3.28 {http::geturl: -headers override -type default} -body {
    set token [http::geturl $url/headers -query dummy \
	    -headers [list "Content-Type" "text/plain;charset=utf-8"]]
    http::data $token
} -cleanup {
    http::cleanup $token
} -match regexp -result {(?n)Host .*

User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
Accept \*/\*
Accept-Encoding .*
Content-Length 5}
test http-3.29 {http::geturl IPv6 address} -body {
    # We only want to see if the URL gets parsed correctly. This is
    # the case if http::geturl succeeds or returns a socket related
    # error. If the parsing is wrong, we'll get a parse error.
    # It'd be better to separate the URL parser from http::geturl, so

} -result 200
test http-3.31 {http::geturl fragment without path} -body {
    set token [http::geturl "$authorityurl#fragment42"]
    http::ncode $token
} -cleanup {
    catch { http::cleanup $token }
} -result 200
# Bug c11a51c482
test http-3.32 {http::geturl: -headers override -accept default} -body {
    set token [http::geturl $url/headers -query dummy \
	    -headers [list "Accept" "text/plain,application/tcl-test-value"]]
    http::data $token
} -cleanup {
    http::cleanup $token
} -match regexp -result {(?n)Host .*
User-Agent .*
Connection close
Accept text/plain,application/tcl-test-value
Accept-Encoding .*
Content-Type application/x-www-form-urlencoded
Content-Length 5}

test http-4.1 {http::Event} -body {
    set token [http::geturl $url -keepalive 0]
    upvar #0 $token data
    array set meta $data(meta)
    expr {($data(totalsize) == $meta(Content-Length))}
} -cleanup {
    http::cleanup $token

	namespace export t next
	namespace ensemble create
    }
    k t create X
} -returnCodes error -cleanup {
    namespace delete k
} -result {wrong # args: should be "k next j"}
test oo-2.9 {construction failures and self creation} -setup {
    set ::result {}
    oo::class create Root
} -body {
    oo::class create A {
	superclass Root
	constructor {} {
	    lappend ::result "in A"
	    error "failure in A"
	}
	destructor {lappend ::result [self]}
    }
    oo::class create B {
	superclass Root
	constructor {} {
	    lappend ::result "in B [self]"
	    error "failure in B"
	}
	destructor {lappend ::result [self]}
    }
    lappend ::result [catch {A create a} msg] $msg
    lappend ::result [catch {B create b} msg] $msg
} -cleanup {
    Root destroy
} -result {{in A} ::a 1 {failure in A} {in B ::b} ::b 1 {failure in B}}

test oo-3.1 {basic test of OO functionality: destructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as we're
    # modifying the root object class's constructor
    interp create subinterp
    subinterp eval {
	package require TclOO

	filter boo
    }
    set log {}
    list [Aobject outerfoo] $log
} -cleanup {
    Aclass destroy
} -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}}
test oo-12.8 {OO: filters and destructors} -setup {
    oo::class create Aclass
    Aclass create Aobject
    set ::log {}
} -body {
    oo::define Aclass {
	constructor {} {
	    lappend ::log "in constructor"
	}
	destructor {
	    lappend ::log "in destructor"
	}
	method bar {} {
	    lappend ::log "in method"
	}
	method Boo args {
	    lappend ::log [self target]
	    next {*}$args
	}
	filter Boo
    }
    set obj [Aclass new]
    $obj bar
    $obj destroy
    return $::log
} -cleanup {
    Aclass destroy
} -result {{in constructor} {::Aclass bar} {in method} {::oo::object destroy} {in destructor}}

test oo-13.1 {OO: changing an object's class} {
    oo::class create Aclass
    oo::define Aclass {method bar {} {lappend ::result "in A [self object]"}}
    oo::class create Bclass
    oo::define Bclass {method bar {} {lappend ::result "in B [self object]"}}
    set result [Aclass create foo]

    }
    set ::result {}
    [B new] destroy
    return $::result
} -cleanup {
    root destroy
} -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}}

# Contributed tests from aspect, related to [0f42ff7871]
#
# dkf's "Principles Leading to a Fix"
#
#   A method ought to work "the same" whether or not it has been overridden by
#   a subclass. A tailcalled command ought to have as parent stack the same
#   thing you'd get with uplevel 1. A subclass will often expect the
#   superclass's result to be the result that would be returned if the
#   subclass was not there.

# Common setup:
#	any invocation of bar should emit "abc\nhi\n" then return to its
#	caller
set testopts {
    -setup {
	oo::class create Master
	oo::class create Foo {
	    superclass Master
	    method bar {} {
		puts abc
		tailcall puts hi
		puts xyz
	    }
	}
	oo::class create Foo2 {
	    superclass Master
	}
    }
    -cleanup {
	Master destroy
    }
}

# these succeed, showing that without [next] the bug doesn't fire
test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body {
    [Foo create foo] bar
} -output [join {abc hi} \n]\n
test next-tailcall-simple-2 "my bar" {*}$testopts -body {
    oo::define Foo method baz {} {
	puts a
	my bar
	puts b
    }
    [Foo create foo] baz
} -output [join {a abc hi b} \n]\n
test next-tailcall-simple-3 "\[self\] bar" {*}$testopts -body {
    oo::define Foo method baz {} {
	puts a
	[self] bar
	puts b
    }
    [Foo create foo] baz
} -output [join {a abc hi b} \n]\n
test next-tailcall-simple-4 "foo bar" {*}$testopts -body {
    oo::define Foo method baz {} {
	puts a
	foo bar
	puts b
    }
    [Foo create foo] baz
} -output [join {a abc hi b} \n]\n

# everything from here on uses [next], and fails on 8.6.4 with compilation
test next-tailcall-superclass-1 "next superclass" {*}$testopts -body {
    oo::define Foo2 {
	superclass Foo
	method bar {} {
	    puts a
	    next
	    puts b
	}
    }
    [Foo2 create foo] bar
} -output [join {a abc hi b} \n]\n
test next-tailcall-superclass-2 "nextto superclass" {*}$testopts -body {
    oo::define Foo2 {
	superclass Foo
	method bar {} {
	    puts a
	    nextto Foo
	    puts b
	}
    }
    [Foo2 create foo] bar
} -output [join {a abc hi b} \n]\n

test next-tailcall-mixin-1 "class mixin" {*}$testopts -body {
    oo::define Foo2 {
	method Bar {} {
	    puts a
	    next
	    puts b
	}
	filter Bar
    }
    oo::define Foo mixin Foo2
    Foo create foo
    foo bar
} -output [join {a abc hi b} \n]\n

test next-tailcall-objmixin-1 "object mixin" {*}$testopts -body {
    oo::define Foo2 {
	method Bar {} {
	    puts a
	    next
	    puts b
	}
	filter Bar
    }
    Foo create foo
    oo::objdefine foo mixin Foo2
    foo bar
} -output [join {a abc hi b} \n]\n

test next-tailcall-filter-1 "filter method" {*}$testopts -body {
    oo::define Foo method Filter {} {
	puts a
	next
	puts b
    }
    oo::define Foo filter Filter
    [Foo new] bar
} -output [join {a abc hi b} \n]\n

test next-tailcall-forward-1 "forward method" {*}$testopts -body {
    proc foobar {} {
	puts "abc"
	tailcall puts "hi"
	puts "xyz"
    }
    oo::define Foo forward foobar foobar
    oo::define Foo2 {
	superclass Foo
	method foobar {} {
	    puts a
	    next
	    puts b
	}
    }
    [Foo2 new] foobar
} -output [join {a abc hi b} \n]\n

test next-tailcall-constructor-1 "next in constructor" -body {
    oo::class create Foo {
	constructor {} {
	    puts abc
	    tailcall puts hi
	    puts xyz
	}
    }
    oo::class create Foo2 {
	superclass Foo
	constructor {} {
	    puts a
	    next
	    puts b
	}
    }
    list [Foo new] [Foo2 new]
    return ""
} -cleanup {
    Foo destroy
} -output [join {abc hi a abc hi b} \n]\n

test next-tailcall-destructor-1 "next in destructor" -body {
    oo::class create Foo {
	destructor {
	    puts abc
	    tailcall puts hi
	    puts xyz
	}
    }
    oo::class create Foo2 {
	superclass Foo
	destructor {
	    puts a
	    next
	    puts b
	}
    }
    Foo create foo
    Foo2 create foo2
    foo destroy
    foo2 destroy
} -output [join {abc hi a abc hi b} \n]\n -cleanup {
    Foo destroy
}

unset testopts

cleanupTests
return

# Local Variables:
# mode: tcl
# End: