#!/vol/pub/narray-0.15/bin/wwwdemo
#
# $Id: limits.tcl,v 1.2 1994/08/04 23:53:17 sls Exp $
#
# This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that: (1) source code distributions
# retain the above copyright notice and this paragraph in its entirety, (2)
# distributions including binary code include the above copyright notice and
# this paragraph in its entirety in the documentation or other materials
# provided with the distribution, and (3) all advertising materials mentioning
# features or use of this software display the following acknowledgement:
# ``This product includes software developed by the University of California,
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
# the University 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 ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#

setrlimit cputime 20
setrlimit datasize [expr 4096*1024]
setrlimit stacksize [expr 64*1024]
setrlimit coredumpsize 0
rename setrlimit ""
#
# $Id: narray.tcl,v 1.12 1994/12/03 02:15:31 sls Exp $
#
# This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that: (1) source code distributions
# retain the above copyright notice and this paragraph in its entirety, (2)
# distributions including binary code include the above copyright notice and
# this paragraph in its entirety in the documentation or other materials
# provided with the distribution, and (3) all advertising materials mentioning
# features or use of this software display the following acknowledgement:
# ``This product includes software developed by the University of California,
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
# the University 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 ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#

set narray_priv(var_counter) 0

# this is just here so that this file can be auto-loaded by saying
# narray_init.  you may have to do this because the tcl auto-load
# mechanism won't auto-load narray define's.
proc narray_init {} {
}

# Print a narray on stdout
proc pnarray {na {format ""}} {
    if ![string length $format] {
	if [catch {set format [$na svref _format]}] {
	    set format "%g"
	}
    }
    puts -nonewline \
	"$na ([$na status] dimensions [list [$na dimensions]]):"
    $na map {
	if @0 == 0 {
	    printf("\n")
	}
	tcl_eval("puts -nonewline \" [format $format ", [], "]\"")
    }
    puts ""
}

# delete an narray
proc narray_delete args {
    foreach na $args {
	rename $na ""
    }
}

# make a local variable
proc narray_variable {method var_name args} {
    global narray_priv
    upvar $var_name var
    set var narray[incr narray_priv(var_counter)]
    eval narray $method $var $args
    trace variable var w {error "can't set narray_variable's" ;#}
    trace variable var u "narray_delete $var ;#"
}

# convert to a list
narray define tolist {} {
    pre {
	# if we're just starting, append a bunch of opening braces
	for (_i = 0; _i < @#-1-1; _i += 1) {
	    tcl_append_result("{");
	}
    }
    # if we're at the begining of a new run, append a open brace
    if @0 == 0 {
	tcl_append_result("{");
    }
    # append the item
    tcl_append_result([]);
    # if we're at the end of a run, print a close brace
    if @0 == @#0-1 {
	tcl_append_result("} ");
    }
    post {
	# if we're at the end, append a bunch of closing braces
	for (_i = 0; _i < @#-1-1; _i += 1) {
	    tcl_append_result("}");
	}
    }
}

# misc operations

narray define copy {{-array _x}} {
    [] = _x[]
}

narray define zero {} {
    [] = 0
}

# scalar operations
foreach narray_priv(op) {+ - * /} {
    narray define s$narray_priv(op) {{-variable _x}} "\[\] $narray_priv(op)= _x;"
}

# generic + and -
narray define + {{-array _b}} {
    [] += _b[]
}

narray define - {{-array _b}} {
    [] -= _b[]
}

# vector operations
narray define dot {{-array _u}} {
    pre {
	_dot = 0;
    }
    _dot += [] * _u[];
    post {
	tcl_append_result(_dot);
    }
}

narray define outer* {{-array _u}} {
    [] *= _u[]
}

# matrix operations

narray define m* {{-array _a} {-array _b}} {
    [] = 0;
    for (_j = 0; _j < _a@#1; _j += 1) {
	[] += _a[_j,@0] * _b[@1,_j]
    }
}

narray define transpose {} {
    if @0 < @1 {
	_tmp = []
	[] = [@0,@1]
	[@0,@1] = _tmp
    }
}
#
# $Id: util.tcl,v 1.2 1994/08/04 23:51:41 sls Exp $
#
# This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that: (1) source code distributions
# retain the above copyright notice and this paragraph in its entirety, (2)
# distributions including binary code include the above copyright notice and
# this paragraph in its entirety in the documentation or other materials
# provided with the distribution, and (3) all advertising materials mentioning
# features or use of this software display the following acknowledgement:
# ``This product includes software developed by the University of California,
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
# the University 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 ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# Various shorthand utility stuff
#
# util(verbose) -- if 1 then msg prints stuff
#

set util(verbose) 0

proc ifexists {var action {else_keyword ""} {else_clause ""}} {
    upvar $var v
    if [info exists v] {
	uplevel $action
	return
    }
    if {$else_keyword == "else"} {
	uplevel $else_clause
    }
}

proc ifnexists {var action {else_keyword ""} {else_clause ""}} {
    upvar $var v
    if ![info exists v] {
	uplevel $action
    }
    if {$else_keyword == "else"} {
	uplevel $else_clause
    }
}

proc msg_verbose {} {
    global util
    set util(verbose) 1
}

proc msg_quiet {} {
    global util
    set util(verbose) 0
}

proc msg {m} {
    global util
    if $util(verbose) {
	puts $m
    }
}

proc args {args tbl} {
    foreach var $tbl {
	upvar [string range $var 1 end] [lindex $var 0]
	if {[llength $var] == 2} {
	    set [lindex $var 0] [lindex $var 1]
	}
    }
    while {[llength $args]} {
	set arg [lindex $args 0]
	if {[lsearch -glob $tbl $arg*] != -1} {
	    set val [lindex $args 1]
	    if {$val != 0} {
		set $arg $val
	    }
	} else {
	    error "unknown argument $arg, should be one of: $tbl"
	}
	set args [lrange $args 2 end]
    }
}

proc append_line {var line} {
    upvar $var v
    append v "\n$line"
}

proc string_range {s p} {
    return [string range $s [lindex $p 0] [lindex $p 1]]
}

proc iswhite {s} {
    return [regexp "^( \t\n)*$" $s]
}

proc string_cap_first {s} {
    return [string toupper [string index $s 0]][string range $s 1 end]
}
#
# $Id: html.tcl,v 1.2 1994/08/04 23:51:12 sls Exp $
#
#
# This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that: (1) source code distributions
# retain the above copyright notice and this paragraph in its entirety, (2)
# distributions including binary code include the above copyright notice and
# this paragraph in its entirety in the documentation or other materials
# provided with the distribution, and (3) all advertising materials mentioning
# features or use of this software display the following acknowledgement:
# ``This product includes software developed by the University of California,
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
# the University 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 ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# html support routines
#
# html(sink) -- proc that prints some text
# html(style) -- current style
# html(style_table) -- table of style names and begin/end directives
#

set html(sink) puts
set html(style) normal
set html(style_table) {
    {normal "" ""}
    {bold <B> </B>}
    {strong <STRONG> </STRONG>}
    {em <EM> </EM>}
    {italic <I> </I>}
    {site <SITE> </SITE>}
    {var <VAR> </VAR>}
    {tt <TT> </TT>}
    {code <CODE> </CODE>}
    {samp <SAMP> </SAMP>}
    {kbd <KBD> </KBD>}
}

proc html_dnl {} {
    global html
    if {$html(sink) == "puts"} {
	set html(sink) html_dnl_sink
    }
}

proc html_dnl_sink {txt} {
    puts -nonewline $txt 
}

proc html_nl {} {
    global html
    if {$html(sink) == "html_dnl_sink"} {
	set html(sink) puts
    }
}

proc html_quote {text} {
    global html
    regsub -all "&" $text "\\&amp;" text
    regsub -all "<" $text "\\&lt;" text
    regsub -all ">" $text "\\&gt;" text
    $html(sink) $text
}

proc html {txt} {
    global html
    $html(sink) $txt
}

proc html_style_lookup {s} {
    global html
    foreach e $html(style_table) {
	if {[lindex $e 0] == $s} {
	    return $e
	}
    }
    error "unknown html style \"$s\""
}

proc html_set_style {s} {
    global html
    if {$s != $html(style)} {
	html [lindex [html_style_lookup $html(style)] 2]
	html [lindex [html_style_lookup $s] 1]
	set html(style) $s
    }
}

proc html_style {s txt} {
    global html
    set old_style $html(style)
    html_set_style $s
    html $txt
    html_set_style $old_style
}

proc html_begin {title} {
    html "<HTML><HEADER>"
    html "<TITLE>$title</TITLE>"
    html "</HEADER><BODY>"
}

proc html_end {} {
    global html
    if {[info commands html_sign] != ""} html_sign
    html "</BODY></HTML>"
}

proc html_heading {hdr {level 1}} {
    html "<H$level>$hdr</H$level>"
}

proc html_run {body} {
    if {[catch {uplevel $body}] == 1} {
	global errorInfo
	html "<HR><H1>Ooops!</H1>An error occurred in a tcl script:"
	html "<LISTING>"
	html "$errorInfo"
	html "</LISTING>"
	html "</HR>"
    }
}
#
# $Id: form.tcl,v 1.3 1994/10/13 19:46:15 sls Exp $
#
# This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that: (1) source code distributions
# retain the above copyright notice and this paragraph in its entirety, (2)
# distributions including binary code include the above copyright notice and
# this paragraph in its entirety in the documentation or other materials
# provided with the distribution, and (3) all advertising materials mentioning
# features or use of this software display the following acknowledgement:
# ``This product includes software developed by the University of California,
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
# the University 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 ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# form support
#
# form(name) -- name of current form
#

proc form_begin {name {action_prefix ""}} {
    global form
    msg [list form_begin $name]
    catch {unset form}
    set form(name) $name
    html "<FORM METHOD=POST ACTION=${action_prefix}${name}>"
}

proc form_listvar args {
    global form
    foreach arg $args {
	lappend form(listvars) $arg
    }
}

proc form_end {} {
    global form
    msg [list form_end $form(name)]
    html "</FORM>"
}

#
# INPUT tag types
#
proc text {args} {
    args $args {-value -name -size -maxlength}
    set txt "<INPUT TYPE=\"text\""
    ifexists value { append txt " VALUE=\"$value\"" }
    ifexists name { append txt " NAME=\"$name\"" }
    ifexists size { append txt " SIZE=\"$size\"" }
    ifexists maxlength { append txt " MAXLENGTH=\"$size\"" }
    append txt ">"
    html $txt
}

proc hidden {args} {
    args $args {-name -value}
    set txt "<INPUT TYPE=\"hidden\" SIZE=1"
    ifexists value { append txt " VALUE=\"$value\"" }
    ifexists name { append txt " NAME=\"$name\"" }
    append txt ">"
    html $txt
}

proc password {args} {
    args $args {-value -name -size -maxlength}
    set txt "<INPUT TYPE=\"password\""
    ifexists value { append txt " VALUE=\"$value\"" }
    ifexists name { append txt " NAME=\"$name\"" }
    ifexists size { append txt " SIZE=\"$size\"" }
    ifexists maxlength { append txt " MAXLENGTH=\"$size\"" }
    append txt ">"
    html $txt
}

proc checkbox {args} {
    args $args {-name -checked -value}
    set txt "<INPUT TYPE=\"checkbox\""
    ifexists name { append txt " NAME=\"$name\"" }
    ifexists value { append txt " VALUE=\"$value\"" }
    ifexists checked { append txt " CHECKED" }
    append txt ">"
    html $txt
}

proc radio {args} {
    args $args {-name -checked -value}
    set txt "<INPUT TYPE=\"radio\""
    ifexists name { append txt " NAME=\"$name\"" }
    ifexists value { append txt " VALUE=\"$value\"" }
    ifexists checked { append txt " CHECKED" }
    append txt ">"
    html $txt
}

proc submit {args} {
    args $args -value
    set txt "<INPUT TYPE=\"submit\""
    ifexists value { append txt " VALUE=\"$value\"" }
    append txt ">"
    html $txt
}

proc reset {args} {
    args $args -value
    set txt "<INPUT TYPE=\"reset\""
    ifexists value { append txt " VALUE=\"$value\"" }
    append txt ">"
    html $txt
}

#
# SELECT box
#
proc select_begin {args} {
    args $args {-name -size -multiple}
    set txt "<SELECT"
    ifexists name { append txt " NAME=\"$name\"" }
    ifexists size { append txt " SIZE=\"$size\"" }
    ifexists multiple { append txt " MULTIPLE" }
    append txt ">"
    html $txt
}

proc option {args} {
    args $args {-selected}
    set txt "<OPTION"
    ifexists selected { append txt " SELECTED" }
    append txt ">"
    html $txt
}

proc select_end {args} {
    args $args {}
    html "</SELECT>"
}

#
# TEXTAREA
#
proc textarea_begin {args} {
    args $args {-name -rows -cols}
    set txt "<TEXTAREA"
    ifexists name { append txt " NAME=\"$name\"" }
    ifexists rows { append txt " ROWS=\"$rows\"" }
    ifexists cols { append txt " COLS=\"$cols\"" }
    append txt ">"
    html $txt
}

proc textarea_end {args} {
    args $args {}
    html "</TEXTAREA>"
}

#
# procs for form-handlers
#

proc cgi_hex_unquote {txt} {
    regsub -all "\\+" $txt " " txt
    while {[regexp -nocase "(\[^%]|^)(%\[0-9A-F]\[0-9A-F])" $txt x y match]} {
        if ![string compare $match "%25"] {
            regsub -all "%25" $txt %% txt
            continue
        }
        scan $match "%%%x" n
        set ch [format "%c" $n]
        if {![string compare $ch "&"]} {
            set ch "\\&"
        }
        regsub -all $match $txt $ch txt
    }
    regsub -all "%%" $txt % txt
    return $txt
}

proc cgi_post_read {{debug 0}} {
    global env ar artype
    if {!([info exists env(REQUEST_METHOD)] && [string tolower $env(REQUEST_METHOD)] == "post")} {
	html_heading "Oops!"
	html "This script must be accessed from a form and not through"
	html "a URL or reloading a page.  Please return to the form"
	html "and resubmit it."
	html_end
	exit 0
    }
    set txt [read_stdin $env(CONTENT_LENGTH)]
    foreach assignment [split $txt &] {
	set assignment [split $assignment =]
	set var [lindex $assignment 0]
	set val [cgi_hex_unquote [lindex $assignment 1]]
	if $debug {
	    puts "<CODE> [list $var = $val] </CODE><P>"
	}
	if {[info exists artype($var)] && $artype($var) == "list"} {
	    lappend ar($var) $val
	} else {
	    set ar($var) $val
	}
    }
}

# for hidden fields, newlines & tabs need to be quoted -- use %xx encoding
# also, double quotes, and <>'s

proc hidden_quote {txt} {
    regsub -all "%" $txt "%25" txt
    regsub -all "\"" $txt "%22" txt
    regsub -all "<" $txt "%3C" txt
    regsub -all ">" $txt "%3E" txt
    regsub -all "\n" $txt "%0A" txt
    regsub -all "\t" $txt "%09" txt
    return $txt
}
#
# $Id: wwwdemo_body.tcl,v 1.4 1994/08/05 04:00:43 sls Exp sls $
#
# This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that: (1) source code distributions
# retain the above copyright notice and this paragraph in its entirety, (2)
# distributions including binary code include the above copyright notice and
# this paragraph in its entirety in the documentation or other materials
# provided with the distribution, and (3) all advertising materials mentioning
# features or use of this software display the following acknowledgement:
# ``This product includes software developed by the University of California,
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
# the University 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 ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#

proc html_sign {} {
    html "<HR><ADDRESS><a href=http://www-cs.lbl.gov/~sls/>Sam Shen</a>, slshen@lbl.gov</ADDRESS>"
}

narray cripple

proc run body {
    if [catch {uplevel $body}] {
	global errorInfo
	puts "Content-type: text/html"
	puts ""
	html "<HR><H1>Ooops!</H1>An error occurred in a tcl script:"
	html "<LISTING>"
	html_quote "$errorInfo"
	html "</LISTING>"
	html "</HR>"
    }
}

run {
    if {[info exists env(REQUEST_METHOD)] && [string tolower $env(REQUEST_METHOD)] == "post"} {
	cgi_post_read
    }
    if [info exists ar(code)] {
	set lines_of_code [split $ar(code) "\n"]
	set line1 [lindex $lines_of_code 0]
	if {[lindex $line1 0] == "content_type"} {
	    puts "Content-type: [lindex $line1 1]"
	    puts ""
	    eval [join [lrange $lines_of_code 1 end] "\n"]
	    exit 0
	}
    }
    puts "Content-type: text/html"
    puts ""
    html_begin "NArray Demo"
    html_heading "NArray Demo"

    html "This is a demo of the narray extension."
    html "The Tcl code you enter below will be evaluated in a restricted"
    html "Tcl interpreter line by line, giving the command result and"
    html "time taken.  Your code will be limited to 20 seconds of cpu"
    html "time, 4M of data, and 64K of stack.  If you exceed these limit"
    html "the server will be unable to complete your request."

    if [info exists lines_of_code] {
	set cmd ""
	html_heading "Previous results:" 2
	foreach line $lines_of_code {
	    append cmd "$line\n"
	    if [info complete $cmd] {
		if ![string length [string trim $cmd]] continue
		html_set_style bold
		html_quote $cmd
		html_set_style normal
		html "<ul>"
		html "<li> Stdout: "
		html_set_style tt
		if [catch {set t [time {set result [eval $cmd]}]}] {
		    html_set_style normal
		    html "<li> Error: "
		    html "<listing>"
		    html $errorInfo
		    html "</listing>"
		} else {
		    html_set_style normal
		    html \
		  "<li> Time: [format %3.2f [expr [lindex $t 0] / 1000.0]]ms"
		    html "<li> Result: "
		    html_set_style tt
		    html_quote $result
		    html_set_style normal		    
		}
		html "</ul>"
		set cmd ""
	    }
	}
    }
    html_heading "Enter Tcl code:" 2
    form_begin wwwdemo.cgi
    submit -value "Evaluate Code"
    html "<P>"
    html_dnl
    textarea_begin -name code -rows 15 -cols 60
    if [info exists ar(code)] {
	html_quote $ar(code)
    }
    textarea_end
    html_nl
    form_end
    html_end
}