Tcl Source Code

Artifact 919cad187ee2f0b1272cd1b167a4c6d44d031ff7:

set script {
    #
    # This is the heapsort proc from tclbench, modified
    # to return immediately
    #

    proc heapsort {n ra_name} {
	return
	upvar 1 $ra_name ra

	set j 0
	set i 0
	set rra 0.0
	set l [expr {($n >> 1) + 1}]
	set ir $n
	while 1 {
	    if {$l > 1} {
		incr l -1
		set rra $ra($l)
	    } else {
		set rra $ra($ir)
		set ra($ir) $ra(1)
		incr ir -1
		if {$ir == 1} {
		    set ra(1) $rra
		    return
		}
	    }
	    set i $l
	    set j [expr {$l << 1}]
	    while {$j <= $ir} {
		if {($j < $ir) && ($ra($j) < $ra([expr {$j + 1}]))} {
		    incr j
		}
		if {$rra < $ra($j)} {
		    set ra($i) $ra($j)
		    set i $j
		    set j [expr {$j + $i}]
		} else {
		    set j [expr {$ir + 1}]
		}
	    }
	    set ra($i) $rra
	}
    }

    #
    # This is the ncgi::redirect proc from the ncgi module in
    # in tcllib,modified to return immediately
    #
    proc redirect {url} {
	return
	global env

	if {![regexp -- {^[^:]+://} $url]} {

	    # The url is relative (no protocol/server spec in it), so
	    # here we create a canonical URL.

	    # request_uri	The current URL used when dealing with relative URLs.  
	    # proto		http or https
	    # server 	The server, which we are careful to match with the
	    #		current one in base Basic Authentication is being used.
	    # port		This is set if it is not the default port.

	    if {[info exist env(REQUEST_URI)]} {
		# Not all servers have the leading protocol spec
		regsub -- {^https?://[^/]*/} $env(REQUEST_URI) / request_uri
	    } elseif {[info exist env(SCRIPT_NAME)]} {
		set request_uri $env(SCRIPT_NAME)
	    } else {
		set request_uri /
	    }

	    set port ""
	    if {[info exist env(HTTPS)] && $env(HTTPS) == "on"} {
		set proto https
		if {$env(SERVER_PORT) != 443} {
		    set port :$env(SERVER_PORT)
		}
	    } else {
		set proto http
		if {$env(SERVER_PORT) != 80} {
		    set port :$env(SERVER_PORT)
		}
	    }
	    # Pick the server from REQUEST_URI so it matches the current
	    # URL.  Otherwise use SERVER_NAME.  These could be different, e.g.,
	    # "pop.scriptics.com" vs. "pop"

	    if {![regexp -- {^https?://([^/:]*)} $env(REQUEST_URI) x server]} {
		set server $env(SERVER_NAME)
	    }
	    if {[string match /* $url]} {
		set url $proto://$server$port$url
	    } else {
		regexp -- {^(.*/)[^/]*$} $request_uri match dirname
		set url $proto://$server$port$dirname$url
	    }
	}
	ncgi::header text/html Location $url
	puts "Please go to <a href=\"$url\">$url</a>"
    }

    #
    # Now force compilation of both procs
    #

    heapsort 1 1
    redirect 1
}

puts [time {eval $script} 10000]