" - echo "Info: https://github.com/hobbyquaker/XML-API" + echo "Info: https://github.com/homematic-community/XML-API" echo "Version: $(cat ${WWW_DIR}/VERSION)" echo "Name: XML-API" echo "Operations: uninstall" diff --git a/xmlapi/DEVDB.tcl b/xmlapi/DEVDB.tcl old mode 100755 new mode 100644 index 7aa64e5..2643d1b --- a/xmlapi/DEVDB.tcl +++ b/xmlapi/DEVDB.tcl @@ -11,7 +11,7 @@ source once.tcl ################################################################################ set DEVDB_DIRECTORY "/www/config/devdescr" -set DEVDB_FILE "/var/tmp/devdb.txt" +set DEVDB_FILE "$DEVDB_DIRECTORY/DEVDB.tcl" ################################################################################ # Globale Variablen # @@ -29,7 +29,7 @@ array set DEV_HIGHLIGHT "" proc devdb_saveToFile { file_name content } { upvar $content file_content - + if { ![catch { open $file_name w } fd] } then { puts $fd $file_content close $fd @@ -53,29 +53,29 @@ proc devdb_loadFromFile { file_name } { ################################################################################ proc AddUIDescription {key} { - global DEV_LIST - - lappend DEV_LIST $key + global DEV_LIST + + lappend DEV_LIST $key } proc AddDescription {key desc} { - global DEV_DESCRIPTION - - set DEV_DESCRIPTION($key) $desc + global DEV_DESCRIPTION + + set DEV_DESCRIPTION($key) $desc } proc AddPaths {key p_PATHS} { - global DEV_PATHS + global DEV_PATHS upvar $p_PATHS PATHS - - set DEV_PATHS($key) $PATHS + + set DEV_PATHS($key) $PATHS } proc AddCoordinates {key p_P} { - global DEV_HIGHLIGHT + global DEV_HIGHLIGHT upvar $p_P P - - set DEV_HIGHLIGHT($key) $P + + set DEV_HIGHLIGHT($key) $P } ################################################################################ @@ -83,26 +83,26 @@ proc AddCoordinates {key p_P} { ################################################################################ proc DEV_getImagePath {key size} { - global DEV_PATHS DEV_LIST - - if { [lsearch $DEV_LIST $key] < 0 } then { return "" } - - set pathlist $DEV_PATHS($key) - set path "" - - foreach px $pathlist { - - set asize [lindex $px 0] - set apath [lindex $px 1] - - if {$asize == $size} then { - set path $apath - break - } - } - - - return $path + global DEV_PATHS DEV_LIST + + if { [lsearch $DEV_LIST $key] < 0 } then { return "" } + + set pathlist $DEV_PATHS($key) + set path "" + + foreach px $pathlist { + + set asize [lindex $px 0] + set apath [lindex $px 1] + + if {$asize == $size} then { + set path $apath + break + } + } + + + return $path } ################################################################################ @@ -111,40 +111,40 @@ proc DEV_getImagePath {key size} { proc PrintCoordinates {} { - global DEV_HIGHLIGHT - foreach descr [array names DEV_HIGHLIGHT] { - - puts "Type: $descr -- Coordinates: $DEV_HIGHLIGHT($descr)" - } + global DEV_HIGHLIGHT + foreach descr [array names DEV_HIGHLIGHT] { + + puts "Type: $descr -- Coordinates: $DEV_HIGHLIGHT($descr)" + } } proc PrintPaths {} { - global DEV_PATHS - foreach descr [array names DEV_PATHS] { - puts "Type: $descr -- Path: $DEV_PATHS($descr)" - } + global DEV_PATHS + foreach descr [array names DEV_PATHS] { + puts "Type: $descr -- Path: $DEV_PATHS($descr)" + } } proc PrintDescriptions {} { - global DEV_DESCRIPTION - foreach descr [array names DEV_DESCRIPTION] { - puts "Type: $descr -- Description: $DEV_DESCRIPTION($descr)" - } + global DEV_DESCRIPTION + foreach descr [array names DEV_DESCRIPTION] { + puts "Type: $descr -- Description: $DEV_DESCRIPTION($descr)" + } } proc PrintList {} { - global DEV_LIST - puts "List: $DEV_LIST" + global DEV_LIST + puts "List: $DEV_LIST" } proc Print {} { - PrintList - PrintDescriptions - PrintPaths - PrintCoordinates + PrintList + PrintDescriptions + PrintPaths + PrintCoordinates } ################################################################################ @@ -152,10 +152,10 @@ proc Print {} { ################################################################################ proc DEVDB_create { } { - global DEVDB_DIRECTORY - + global DEVDB_DIRECTORY + set filelist [glob -nocomplain "$DEVDB_DIRECTORY/*.tcl"] - + foreach file $filelist { if {[file tail $file] == "DEVDB.tcl"} then { continue } @@ -164,14 +164,14 @@ proc DEVDB_create { } { set DESCRIPTION "" set PATHLIST "" set P "" - + sourceOnce $file catch { AddUIDescription $TYPE AddDescription $TYPE $DESCRIPTION AddPaths $TYPE PATHLIST - AddCoordinates $TYPE P + AddCoordinates $TYPE P } } } @@ -179,15 +179,15 @@ proc DEVDB_create { } { proc DEVDB_save { } { global DEVDB_FILE global DEV_LIST DEV_DESCRIPTION DEV_PATHS DEV_HIGHLIGHT - + array set debdb "" set devdb(DEV_LIST) $DEV_LIST set devdb(DEV_DESCRIPTION) [array get DEV_DESCRIPTION] set devdb(DEV_PATHS) [array get DEV_PATHS] set devdb(DEV_HIGHLIGHT) [array get DEV_HIGHLIGHT] - + set content [array get devdb] - + devdb_saveToFile $DEVDB_FILE content } @@ -207,7 +207,7 @@ proc DEVDB_load { } { array set DEV_PATHS $devdb(DEV_PATHS) array set DEV_HIGHLIGHT $devdb(DEV_HIGHLIGHT) } - + } ################################################################################ @@ -216,21 +216,21 @@ proc DEVDB_load { } { #proc Clear {} { # -# global DEV_LIST DEV_DESCRIPTION DEV_PATHS DEV_HIGHLIGHT -# -# set DEV_LIST "" -# array_clear DEV_DESCRIPTION "" -# array_clear DEV_PATHS "" -# array_clear DEV_HIGHLIGHT "" +# global DEV_LIST DEV_DESCRIPTION DEV_PATHS DEV_HIGHLIGHT +# +# set DEV_LIST "" +# array_clear DEV_DESCRIPTION "" +# array_clear DEV_PATHS "" +# array_clear DEV_HIGHLIGHT "" #} - + ################################################################################ # Einsprungpunkt # ################################################################################ -if { ![file exists $DEVDB_FILE] } then { - DEVDB_create - DEVDB_save -} else { +#if { ![file exists $DEVDB_FILE] } then { +# DEVDB_create +# DEVDB_save +#} else { DEVDB_load -} +#} diff --git a/xmlapi/cgi.tcl b/xmlapi/cgi.tcl old mode 100755 new mode 100644 index 21b2565..d4cef62 --- a/xmlapi/cgi.tcl +++ b/xmlapi/cgi.tcl @@ -22,14 +22,14 @@ proc cgi_http_head {args} { set _cgi(http_head_in_progress) 1 if {0 == [llength $args]} { - cgi_content_type + cgi_content_type cgi_puts "Expires: Sun, 06 Nov 1994 00:00:00 GMT" } else { - if {[catch {uplevel 1 [lindex $args 0]} errMsg]} { - set savedInfo $errorInfo - cgi_content_type + if {[catch {uplevel 1 [lindex $args 0]} errMsg]} { + set savedInfo $errorInfo + cgi_content_type cgi_puts "Expires: Sun, 06 Nov 1994 00:00:00 GMT" - } + } } cgi_puts "" @@ -37,7 +37,7 @@ proc cgi_http_head {args} { set _cgi(http_head_done) 1 if {[info exists savedInfo]} { - error $errMsg $savedInfo + error $errMsg $savedInfo } } @@ -63,18 +63,18 @@ proc cgi_content_type {args} { global _cgi if {0==[llength $args]} { - set t text/html + set t text/html } else { - set t [lindex $args 0] - if {[regexp ^multipart/ $t]} { - set _cgi(multipart) 1 - } + set t [lindex $args 0] + if {[regexp ^multipart/ $t]} { + set _cgi(multipart) 1 + } } if {[info exists _cgi(http_head_in_progress)]} { - cgi_puts "Content-type: $t" + cgi_puts "Content-type: $t" } else { - cgi_http_head [list cgi_content_type $t] + cgi_http_head [list cgi_content_type $t] } } @@ -82,13 +82,13 @@ proc cgi_redirect {t} { global _cgi if {[info exists _cgi(http_head_in_progress)]} { - cgi_status 302 Redirected - cgi_puts "Uri: $t" - cgi_puts "Location: $t" + cgi_status 302 Redirected + cgi_puts "Uri: $t" + cgi_puts "Location: $t" } else { - cgi_http_head { - cgi_redirect $t - } + cgi_http_head { + cgi_redirect $t + } } } @@ -97,9 +97,9 @@ proc cgi_location {t} { global _cgi if {[info exists _cgi(http_head_in_progress)]} { - cgi_puts "Location: $t" + cgi_puts "Location: $t" } else { - cgi_http_head "cgi_location $t" + cgi_http_head "cgi_location $t" } } @@ -107,7 +107,7 @@ proc cgi_target {t} { global _cgi if {![info exists _cgi(http_head_in_progress)]} { - error "cgi_target must be set from within cgi_http_head." + error "cgi_target must be set from within cgi_http_head." } cgi_puts "Window-target: $t" } @@ -118,12 +118,12 @@ proc cgi_refresh {seconds {url ""}} { global _cgi if {![info exists _cgi(http_head_in_progress)]} { - error "cgi_refresh must be set from within cgi_http_head. Try using cgi_http_equiv instead." + error "cgi_refresh must be set from within cgi_http_head. Try using cgi_http_equiv instead." } cgi_put "Refresh: $seconds" if {0!=[string compare $url ""]} { - cgi_put "; $url" + cgi_put "; $url" } cgi_puts "" } @@ -133,7 +133,7 @@ proc cgi_pragma {arg} { global _cgi if {![info exists _cgi(http_head_in_progress)]} { - error "cgi_pragma must be set from within cgi_http_head." + error "cgi_pragma must be set from within cgi_http_head." } cgi_puts "Pragma: $arg" } @@ -142,9 +142,9 @@ proc cgi_pragma {arg} { # support for debugging or other crucial things we need immediately ################################################## -proc cgi_comment {args} {} ;# need this asap +proc cgi_comment {args} {} ;# need this asap -proc cgi_html_comment {args} { +proc cgi_html_comment {args} { regsub -all {>} $args {\>} args cgi_put "" } @@ -156,51 +156,51 @@ proc cgi_debug {args} { set old $_cgi(debug) set arg [lindex $args 0] if {$arg == "-on"} { - set _cgi(debug) -on - set args [lrange $args 1 end] + set _cgi(debug) -on + set args [lrange $args 1 end] } elseif {$arg == "-off"} { - set _cgi(debug) -off - set args [lrange $args 1 end] + set _cgi(debug) -off + set args [lrange $args 1 end] } elseif {[regexp "^-t" $arg]} { - set temp 1 - set _cgi(debug) -on - set args [lrange $args 1 end] + set temp 1 + set _cgi(debug) -on + set args [lrange $args 1 end] } elseif {[regexp "^-noprint$" $arg]} { - set noprint 1 - set args [lrange $args 1 end] + set noprint 1 + set args [lrange $args 1 end] } set arg [lindex $args 0] if {$arg == "--"} { - set args [lrange $args 1 end] + set args [lrange $args 1 end] } if {[llength $args]} { - if {$_cgi(debug) == "-on"} { - - _cgi_close_tag - # force http head and open html, head, body - catch { - if {[info exists noprint]} { - uplevel 1 [lindex $args 0] - } else { - cgi_html { - cgi_head { - cgi_title "debugging before complete HTML head" - } - # force body open and leave open - _cgi_body_start - uplevel 1 [lindex $args 0] - # bop back out to catch, so we don't close body - error "ignore" - } - } - } - } + if {$_cgi(debug) == "-on"} { + + _cgi_close_tag + # force http head and open html, head, body + catch { + if {[info exists noprint]} { + uplevel 1 [lindex $args 0] + } else { + cgi_html { + cgi_head { + cgi_title "debugging before complete HTML head" + } + # force body open and leave open + _cgi_body_start + uplevel 1 [lindex $args 0] + # bop back out to catch, so we don't close body + error "ignore" + } + } + } + } } if {[info exists temp]} { - set _cgi(debug) $old + set _cgi(debug) $old } return $old } @@ -212,19 +212,19 @@ proc cgi_uid_check {user} { if {[regexp "^-off$" $user]} return if {[info exists env(USER)]} { - set whoami $env(USER) + set whoami $env(USER) } elseif {0==[catch {exec whoami} whoami]} { - # "who am i" on some Linux hosts returns "" so try whoami first + # "who am i" on some Linux hosts returns "" so try whoami first } elseif {0==[catch {exec who am i} whoami]} { - # skip over "host!" - regexp "(.*!)?(\[^ \t]*)" $whoami dummy dummy whoami + # skip over "host!" + regexp "(.*!)?(\[^ \t]*)" $whoami dummy dummy whoami } elseif {0==[catch {package require registry}]} { - set whoami [registry get HKEY_LOCAL_MACHINE\\Network\\Logon username] + set whoami [registry get HKEY_LOCAL_MACHINE\\Network\\Logon username] } else { - set whoami $user ;# give up and let go + set whoami $user ;# give up and let go } if {$whoami != "$user"} { - error "Warning: This CGI script expects to run with uid \"$user\". However, this script is running as \"$whoami\"." + error "Warning: This CGI script expects to run with uid \"$user\". However, this script is running as \"$whoami\"." } } @@ -233,21 +233,21 @@ proc cgi_uid_check {user} { proc cgi_parray {a {pattern *}} { upvar 1 $a array if {![array exists array]} { - error "\"$a\" isn't an array" + error "\"$a\" isn't an array" } set maxl 0 foreach name [lsort [array names array $pattern]] { - if {[string length $name] > $maxl} { - set maxl [string length $name] - } + if {[string length $name] > $maxl} { + set maxl [string length $name] + } } cgi_preformatted { - set maxl [expr {$maxl + [string length $a] + 2}] - foreach name [lsort [array names array $pattern]] { - set nameString [format %s(%s) $a $name] - cgi_puts [cgi_quote_html [format "%-*s = %s" $maxl $nameString $array($name)]] - } + set maxl [expr {$maxl + [string length $a] + 2}] + foreach name [lsort [array names array $pattern]] { + set nameString [format %s(%s) $a $name] + cgi_puts [cgi_quote_html [format "%-*s = %s" $maxl $nameString $array($name)]] + } } } @@ -258,67 +258,67 @@ proc cgi_eval {cmd} { set _cgi(body) $cmd uplevel 1 { - global env _cgi errorInfo - - if {1==[catch $_cgi(body) errMsg]} { - # error occurred, handle it - set _cgi(errorInfo) $errorInfo - - if {![info exists env(REQUEST_METHOD)]} { - puts stderr $_cgi(errorInfo) - return - } - # the following code is all to force browsers into a state - # such that diagnostics can be reliably shown - - # close irrelevant things - _cgi_close_procs - # force http head and open html, head, body - cgi_html { - cgi_body { - if {[info exists _cgi(client_error)]} { - cgi_h3 "Client Error" - cgi_p "$errMsg Report this to your system administrator or browser vendor." - } else { - cgi_put [cgi_anchor_name cgierror] - cgi_h3 "An internal error was detected in the service\ - software. The diagnostics are being emailed to\ - the service system administrator ($_cgi(admin_email))." - - if {$_cgi(debug) == "-on"} { - cgi_puts "Heck, since you're debugging, I'll show you the\ - errors right here:" - # suppress formatting - cgi_preformatted { - cgi_puts [cgi_quote_html $_cgi(errorInfo)] - } - } else { - cgi_mail_start $_cgi(admin_email) - cgi_mail_add "Subject: [cgi_name] CGI problem" - cgi_mail_add - cgi_mail_add "CGI environment:" - cgi_mail_add "REQUEST_METHOD: $env(REQUEST_METHOD)" - cgi_mail_add "SCRIPT_NAME: $env(SCRIPT_NAME)" - # this next few things probably don't need - # a catch but I'm not positive - catch {cgi_mail_add "HTTP_USER_AGENT: $env(HTTP_USER_AGENT)"} - catch {cgi_mail_add "HTTP_REFERER: $env(HTTP_REFERER)"} - catch {cgi_mail_add "HTTP_HOST: $env(HTTP_HOST)"} - catch {cgi_mail_add "REMOTE_HOST: $env(REMOTE_HOST)"} - catch {cgi_mail_add "REMOTE_ADDR: $env(REMOTE_ADDR)"} - cgi_mail_add "cgi.tcl version: 1.8.0" - cgi_mail_add "input:" - catch {cgi_mail_add $_cgi(input)} - cgi_mail_add "cookie:" - catch {cgi_mail_add $env(HTTP_COOKIE)} - cgi_mail_add "errorInfo:" - cgi_mail_add "$_cgi(errorInfo)" - cgi_mail_end - } - } - } ;# end cgi_body - } ;# end cgi_html - } ;# end catch + global env _cgi errorInfo + + if {1==[catch $_cgi(body) errMsg]} { + # error occurred, handle it + set _cgi(errorInfo) $errorInfo + + if {![info exists env(REQUEST_METHOD)]} { + puts stderr $_cgi(errorInfo) + return + } + # the following code is all to force browsers into a state + # such that diagnostics can be reliably shown + + # close irrelevant things + _cgi_close_procs + # force http head and open html, head, body + cgi_html { + cgi_body { + if {[info exists _cgi(client_error)]} { + cgi_h3 "Client Error" + cgi_p "$errMsg Report this to your system administrator or browser vendor." + } else { + cgi_put [cgi_anchor_name cgierror] + cgi_h3 "An internal error was detected in the service\ + software. The diagnostics are being emailed to\ + the service system administrator ($_cgi(admin_email))." + + if {$_cgi(debug) == "-on"} { + cgi_puts "Heck, since you're debugging, I'll show you the\ + errors right here:" + # suppress formatting + cgi_preformatted { + cgi_puts [cgi_quote_html $_cgi(errorInfo)] + } + } else { + cgi_mail_start $_cgi(admin_email) + cgi_mail_add "Subject: [cgi_name] CGI problem" + cgi_mail_add + cgi_mail_add "CGI environment:" + cgi_mail_add "REQUEST_METHOD: $env(REQUEST_METHOD)" + cgi_mail_add "SCRIPT_NAME: $env(SCRIPT_NAME)" + # this next few things probably don't need + # a catch but I'm not positive + catch {cgi_mail_add "HTTP_USER_AGENT: $env(HTTP_USER_AGENT)"} + catch {cgi_mail_add "HTTP_REFERER: $env(HTTP_REFERER)"} + catch {cgi_mail_add "HTTP_HOST: $env(HTTP_HOST)"} + catch {cgi_mail_add "REMOTE_HOST: $env(REMOTE_HOST)"} + catch {cgi_mail_add "REMOTE_ADDR: $env(REMOTE_ADDR)"} + cgi_mail_add "cgi.tcl version: 1.8.0" + cgi_mail_add "input:" + catch {cgi_mail_add $_cgi(input)} + cgi_mail_add "cookie:" + catch {cgi_mail_add $env(HTTP_COOKIE)} + cgi_mail_add "errorInfo:" + cgi_mail_add "$_cgi(errorInfo)" + cgi_mail_end + } + } + } ;# end cgi_body + } ;# end cgi_html + } ;# end catch } ;# end uplevel } @@ -341,9 +341,9 @@ proc cgi_root {args} { global _cgi if {[llength $args]} { - set _cgi(root) [lindex $args 0] + set _cgi(root) [lindex $args 0] } else { - set _cgi(root) + set _cgi(root) } } @@ -353,35 +353,35 @@ proc cgi_cgi {args} { set root $_cgi(root) if {0!=[string compare $root ""]} { - if {![regexp "/$" $root]} { - append root "/" - } + if {![regexp "/$" $root]} { + append root "/" + } } - + set suffix [cgi_suffix] set arg [lindex $args 0] if {0==[string compare $arg "-suffix"]} { - set suffix [lindex $args 1] - set args [lrange $args 2 end] + set suffix [lindex $args 1] + set args [lrange $args 2 end] } if {[llength $args]==1} { - return $root[lindex $args 0]$suffix + return $root[lindex $args 0]$suffix } else { - return $root[lindex $args 0]$suffix?[join [lrange $args 1 end] &] + return $root[lindex $args 0]$suffix?[join [lrange $args 1 end] &] } } proc cgi_suffix {args} { global _cgi if {[llength $args] > 0} { - set _cgi(suffix) [lindex $args 0] + set _cgi(suffix) [lindex $args 0] } if {![info exists _cgi(suffix)]} { - return .cgi + return .cgi } else { - return $_cgi(suffix) + return $_cgi(suffix) } } @@ -405,14 +405,14 @@ proc cgi_link {args} { set tag [lindex $args 0] switch -- [llength $args] { - 1 { - set label $_cgi_link($tag,label) - } 2 { - set label [lindex $args end] - } default { - set _cgi_link($tag,label) [set label [lindex $args 1]] - set _cgi_link($tag,url) [lrange $args 2 end] - } + 1 { + set label $_cgi_link($tag,label) + } 2 { + set label [lindex $args end] + } default { + set _cgi_link($tag,label) [set label [lindex $args 1]] + set _cgi_link($tag,url) [lrange $args 2 end] + } } return [eval cgi_url [list $label] $_cgi_link($tag,url)] @@ -425,7 +425,7 @@ proc cgi_imglink {args} { set tag [lindex $args 0] if {[llength $args] >= 2} { - set _cgi_imglink($tag) [eval cgi_img [lrange $args 1 end]] + set _cgi_imglink($tag) [eval cgi_img [lrange $args 1 end]] } return $_cgi_imglink($tag) } @@ -452,11 +452,11 @@ proc cgi_url {display args} { set buf "$display" } @@ -480,13 +480,13 @@ proc cgi_img {args} { set buf "
$s} # Shorthand for
. We used to use tags but that
# is now officially unsupported.
-proc cgi_center {cmd} {
+proc cgi_center {cmd} {
uplevel 1 "cgi_division align=center [list $cmd]"
}
@@ -648,7 +648,7 @@ proc cgi_division {args} {
_cgi_close_proc_push "cgi_put
"
if {[llength $args]} {
- cgi_put "[_cgi_lrange $args 0 [expr {[llength $args]-2}]]"
+ cgi_put "[_cgi_lrange $args 0 [expr {[llength $args]-2}]]"
}
cgi_put ">"
uplevel 1 [lindex $args end]
@@ -660,7 +660,7 @@ proc cgi_preformatted {args} {
_cgi_close_proc_push "cgi_put "
if {[llength $args]} {
- cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
+ cgi_put "[_cgi_lrange $args 0 [expr [llength $args]-2]]"
}
cgi_put ">"
uplevel 1 [lindex $args end]
@@ -674,7 +674,7 @@ proc cgi_preformatted {args} {
proc cgi_li {args} {
cgi_put $_cgi(input)"} - catch {cgi_puts "Cookie:
$env(HTTP_COOKIE)"} + global env + catch {cgi_puts "Input:
$_cgi(input)"} + catch {cgi_puts "Cookie:
$env(HTTP_COOKIE)"} } if {![info exists _cgi(errorInfo)]} { - uplevel 2 app_body_start + uplevel 2 app_body_start } } proc _cgi_body_end {} { global _cgi if {![info exists _cgi(errorInfo)]} { - uplevel 2 app_body_end + uplevel 2 app_body_end } unset _cgi(body_in_progress) cgi_puts "