#!/usr/local/bin/tclsh
#
# Copyright (c): Uwe Schmidt, FH Wedel
#
# You may study, modify and distribute this source code
# FOR NON-COMMERCIAL PURPOSES ONLY.
# This copyright message has to remain unchanged.
#
# Note that this document is provided 'as is',
# WITHOUT WARRANTY of any kind either expressed or implied.

# $Id: cgi-args.cgi,v 1.2 2006-12-30 15:49:55 uwe Exp $
# Lesen und dekodieren von CGI QUERIES

# cgi_argl ist eine Liste von NAME=wert Paaren
# 	diese wird von "get_cgi_args" aufgebaut
#	in Abhaengigkeit von der REQUEST_METHOD
# cgi_argl_read
#	zeigt an, ob die Liste schon eingelesen wurde

set cgi_argl ""
set cgi_argl_read 0
set cgi_input ""

# ------------------------------------------------------------------------------
#
# get_cgi_args
#	REQUEST_METHOD=GET          : Daten in QUERY_STRING Umgebungsvariable
#	REQUEST_METHOD=POST         : Daten kommen aus stdin
#	REQUEST_METHOD nicht gesetzt: Testfall: Daten kommen aus argv

proc get_cgi_args {} {
    global env argv cgi_input

    if {! [info exists env(REQUEST_METHOD)] } {
	set cgi_input [join $argv "&"]
    } elseif {"$env(REQUEST_METHOD)"=="GET"} {
	set cgi_input $env(QUERY_STRING)
    } else {
	# method = POST
	# remove trailing white space: cr or something else
	set cgi_input [string trim [ gets stdin ]]
    }

    return $cgi_input
}


# ------------------------------------------------------------------------------
#
# split_cgi_args
#	zerlegt des String s in eine Liste: Trennzeichen ist &
#	jeder Teil wird einzeln decodiert

proc split_cgi_args s {
    set argl [split $s "&"]

    foreach i $argl {
	lappend rl [decode_cgi_args $i]
    }
    if [info exists rl] {
	return $rl
    } else {
	return ""
    }
}

# ------------------------------------------------------------------------------
#
# decode_cgi_args
#	zerlegt eine Zeichenreihe in NAME und WERT

proc decode_cgi_args s {
    set argl [split $s "="]
    foreach i $argl {
        lappend rl [trans_cgi_str $i]
    }
    if {[llength $rl]==1} {
	lappend $rl {}
    }
    return $rl
}

# ------------------------------------------------------------------------------
#
# trans_cgi_str
#	decodiert Zwichenraum, Zeilenvorschub und %xx Hexawerte


proc trans_cgi_str str {
    regsub -all -- {\+}      $str " "   str
    regsub -all -- {%0D%0A}  $str {\n}  str
    regsub -all -- {%2F}     $str {/}   str
    regsub -all -- {%(..)}   $str {[subst \x\1]} str
    return [subst -novariables $str]
}


# ------------------------------------------------------------------------------
#
# Zugriffsfunktionen
#
# get_cgi_argl
#	gibt die ganze decodierte Liste zurueck

proc get_cgi_argl {} {
    global cgi_argl cgi_argl_read

    if {! $cgi_argl_read} {
	set cgi_argl [split_cgi_args [get_cgi_args]]
	set cgi_argl_read 1

    # global trace
    # puts $trace "get_cgi_argl: $cgi_argl"

    }

    return $cgi_argl
}

# ------------------------------------------------------------------------------
#
# get_cgi_arg
#	sucht fuer einen Namen alle Werte in der cgi Liste
#	ist der Parametername nicht gesetzt wird ein default Wert zurueckgegeben
#	ist der NAME mehrfach vorhanden, wird eine tcl Liste mit allen Werten erzeugt
#	BS:
#	get_cgi_arg NAME unbekannt
#		NAME=wert          --> wert
#		NAME=wert1
#		NAME=wert2         --> {wert1 wert2}
#		NAME nicht gesetzt --> unbekannt

proc get_cgi_arg {name {default {}}} {

    foreach pair [get_cgi_argl] {
	if {"[lindex $pair 0]"=="$name"} {
	    lappend rl [lindex $pair 1]
	}
    }

    if [info exist rl] {
	return $rl
    } else {
	return $default
    }
}

# ------------------------------------------------------------------------------
#
# get_cgi_arg_text
#	arbeitet wie get_cgi_arg
#	nur bei Listen werden alle Listenelemente zu einem Text zusammengefasst
#	{wert1 wert2} --> "wert1 wert2"

proc get_cgi_arg_text {name {default {}}} {
    set r [string trim [join [get_cgi_arg $name $default]]]
    if {"$r"==""} {
	return $default
    } else {
	return $r
    }
}

# ------------------------------------------------------------------------------
#

proc get_cgi_input {} {
    global  cgi_input

    get_cgi_argl
    return $cgi_input
}
# ------------------------------------------------------------------------------
#