src/generic/script.ws3

#
# script.ws3 -- the commands of websh3 that are implemented as Tcl scripts
# nca-073-9
#
# Copyright (C) 1996-2000 by Netcetera AG.
# Copyright (C) 2001 by Apache Software Foundation.
# All rights reserved.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# @(#) $Id$
#

#-----------------------------------------------------------------------------
# namespace init (make sure web:: exists)
#-----------------------------------------------------------------------------
namespace eval web {}

#-----------------------------------------------------------------------------
# web::putxfile
#-----------------------------------------------------------------------------
proc web::putxfile {file {channel ""} {vmsg ""}} {

    if {[string length $vmsg]} {
	upvar $vmsg msg
    }
    if {[string length $channel]} {
	# file is actually the channel and channel is the file
	if {[web::readfile $channel content msg]} {
	    return 1
	}
	return [catch {uplevel [list web::putx $file $content]} msg]
    } else {
	if {[web::readfile $file content msg]} {
	    return 1
	}
	return [catch {uplevel [list web::putx $content]} msg]
    }
}

#-----------------------------------------------------------------------------
# web::readfile
#-----------------------------------------------------------------------------
proc web::readfile {name vtarget {vmsg ""}} {

    upvar $vtarget target
    if {[string length $vmsg]} {
	upvar $vmsg msg
    }
    return [catch {
	set fh [open $name r]
	set target [read $fh]
	close $fh
    } msg]
}

#-----------------------------------------------------------------------------
# web_include
#-----------------------------------------------------------------------------
proc web::include {name {vmsg ""}} {

    if {[string length $vmsg]} {
	upvar $vmsg msg
    }
    if {![file exists $name]} {
	set so "$name[info sharedlibextension]"
	if {[file exists $so]} {
	    return [catch {uplevel [list load $so]} msg]
	}
    }
    return [catch {uplevel [list source $name]} msg]
}

#-----------------------------------------------------------------------------
# web::match
# 1: string to be returned if $val exists in $list
# 2: list to be searched for $val
# 3: string to search
#-----------------------------------------------------------------------------
proc web::match {res list val} {

    if {[lsearch -exact $list $val] >= 0} {
	return $res
    }
    return ""
}

#-----------------------------------------------------------------------------
# web::list2uri
#-----------------------------------------------------------------------------
proc web::list2uri {list} {

    if {[llength $list] % 2} {
	error "list must have even number of elems"
    }

    set pairs {}
    foreach {k v} $list {
	lappend pairs [join [list [uriencode $k] [uriencode $v] ] = ]
    }
    return [join $pairs &]
}

#-----------------------------------------------------------------------------
# web::uri2list
#-----------------------------------------------------------------------------
proc web::uri2list {string} {

    # special case: must return a list with an even # of elements
    set res ""
    foreach item [split $string &] {
	set kv [split $item =]
	if [llength $kv] {
	    lappend res [uridecode [lindex $kv 0]] [uridecode [lindex $kv 1]]
	}
    }
    return $res
}

#-----------------------------------------------------------------------------
# mod_websh and CGI stuff
#-----------------------------------------------------------------------------

#-----------------------------------------------------------------------------
# per request init and cleanup for mod_websh

namespace eval web::ap {}

proc web::ap::perReqInit {} {
}

proc web::ap::perReqCleanup {} {
    # reset logging (except stuff from web::initializer)
    web::loglevel delete -requests
    web::logdest delete -requests
    # reset request data
    web::request -reset
    # reset response channels
    web::response -resetall
    # reset url data
    web::cmdurlcfg -reset
}

#-----------------------------------------------------------------------------
# setup environment for cgi mode

namespace eval web::cgi {}

proc web::cgi::copyenv {} {

    set cgienv {
	SERVER_SOFTWARE
	SERVER_NAME
	GATEWAY_INTERFACE
	SERVER_PROTOCOL
	SERVER_PORT
	REQUEST_METHOD
	PATH_INFO
	PATH_TRANSLATED
	SCRIPT_NAME
	QUERY_STRING
	REMOTE_HOST
	REMOTE_ADDR
	AUTH_TYPE
	REMOTE_USER
	REMOTE_IDENT
	CONTENT_TYPE
	CONTENT_LENGTH
	HTTPS
    }

    # set request headers from environment
    foreach e [array names ::env] {
	if {![string match HTTP_* $e]} {
	    if {[lsearch -exact $cgienv $e] == -1} continue
	}
	web::request -set $e $::env($e)
    }
    
    # check for Authorization
    if {![info exists ::env(REMOTE_USER)] && [info exists ::env(AUTH_BASIC)]} {
	# AUTH_BASIC contains the Authorization header
	# sent by the browser (e.g. created using Apache >= 2.0.51: 
	#   SetEnvIf Authorization "^(Basic .+)$" AUTH_BASIC=$1
	# check the quick reference for security considerations
	if {[regexp "^Basic (.*)" $::env(AUTH_BASIC) dummy authstring]} {
	    # base64 decode it
	    set i 0
	    foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
		    a b c d e f g h i j k l m n o p q r s t u v w x y z \
		    0 1 2 3 4 5 6 7 8 9 + / =} {
		set b64($char) $i
		incr i
	    }
	    set decoded {}
	    set group 0; set j 18; set eq 0
	    foreach char [split $authstring {}] {

		# ignore all characters not in base64 character set
		# should be only newlines, but who knows ;-)
		if {![info exists b64($char)]} {continue}

		if {[string compare $char "="]} {
		    set bits $b64($char)
		    set group [expr {$group | ($bits << $j)}]
		} else {
		    incr eq
		}
		
		if {[incr j -6] < 0} {
		    scan [format %06x $group] %2x%2x%2x a b c
		    switch $eq {
			0 {append decoded [format %c%c%c $a $b $c]}
			1 {append decoded [format %c%c $a $b]}
			2 {append decoded [format %c $a]}
		    }
		    set group 0; set j 18; set eq 0
		}
	    }
	    # set request params
	    web::request -set AUTH_USER [lindex [split $decoded :] 0]
	    web::request -set AUTH_PW [join [lrange [split $decoded :] 1 end] :]
	}
    }
    if {[info exists ::env(AUTH_BASIC)]} {
	unset ::env(AUTH_BASIC)
    }
 }