#!/usr/bin/env tclsh # $Id$ set KOAKUMA_VERSION "1.00" set components "" proc exiting {code} { exit $code } proc loop_components {run} { global components foreach {name description version} $components { eval $run } } proc crash {reason} { global components KOAKUMA_VERSION puts stderr "----- Start Koakuma Crash dump log -----" puts stderr "Included components:" loop_components { puts stderr " $name: $description, version $version" } puts stderr "Reason: $reason" puts stderr "----- End Koakuma Crash dump log -----" puts "Content-Type: text/html" puts "Status: 500 Internal Server Error" puts "" puts "" puts "" puts " " puts " " puts " Oops" puts " " puts " " puts "

Oops

" puts "
" puts " Koakuma version $KOAKUMA_VERSION crashed, reason: $reason
" puts " See the server error log for details." puts " " puts "" exiting 1 } if { ![info exists env(PATH_INFO)] } { puts "Status: 301 Moved Permanently" puts "Location: $env(SCRIPT_NAME)/" puts "" exiting 0 } if { [catch { package require tdom }] } { crash "Failed to load tDOM" } if { [catch { foreach path [glob @@PREFIX@@/lib/koakuma/component/*.tcl] { source "$path" } }] } { crash "Could not load components" } set toc "" set result "" set content "" proc rputs {data} { global result if { "$result" == "" } { set result "$data" } else { set result "$result\n$data" } } proc tputs {data} { global content if { "$content" == "" } { set content "$data" } else { set content "$content\n$data" } } proc html_escape {data} { return "[regsub -all {&} "[regsub -all {>} "[regsub -all {<} "$data" "<"]" ">"]" "&"]" } proc open_projects {} { while 1 { if { ![info exists "@@PREFIX@@/lib/koakuma/db/projects.lock"] } { break } set fid [open "@@PREFIX@@/lib/koakuma/db/projects.lock" "w"] if { ![info exists "/proc/[gets $fid line]"] } { close $fid break } after 10 close $fid } set fid [open "@@PREFIX@@/lib/koakuma/db/projects.lock" "w"] puts $fid "[pid]" close $fid } proc scan_projects {run} { set fid [open "@@PREFIX@@/lib/koakuma/db/projects.db" "r"] set content "" while { [gets $fid line] >= 0 } { if { "$content" == "" } { set content "$line" } else { set content "$content\n$line" } } close $fid set dom [dom parse "$content"] set doc [$dom documentElement] foreach elem [$doc selectNodes "/projects/project"] { set name "[$elem selectNodes "string(name)"]" set description "[$elem selectNodes "string(description)"]" eval $run } } proc project_exists {projname} { set desc "" scan_projects { upvar 1 desc desc upvar 1 projname projname if { "$name" == "$projname" } { set desc "$description" break } } return "$desc" } proc close_projects {} { file delete "@@PREFIX@@/lib/koakuma/db/projects.lock" } proc start_html {title has_toc} { global toc rputs "" rputs "" rputs " " rputs " " rputs " $title - Koakuma" rputs " " rputs " " rputs " " rputs " " rputs " \"Koakuma" rputs " " rputs "
" rputs "
" rputs " Koakuma" rputs "
" rputs "
" if { "$has_toc" == "1" } { rputs "
" rputs "
TOC
" foreach sect $toc { if { "[string range "[regsub -all { } "$sect" "-"]" 0 0]" == "-" } { rputs "[regsub {^-} "$sect" ""]
" } else { rputs "$sect
" } } rputs "
" } if { "$has_toc" == "1" } { rputs "
" } else { rputs "
" } rputs "

$title

" } proc end_html {has_toc} { global KOAKUMA_VERSION rputs "
" rputs "
" rputs " Powered by Koakuma $KOAKUMA_VERSION" rputs " " rputs "" } proc add_toc {data} { global toc tputs "

# $data

" lappend toc "$data" } proc add_toc2 {data} { global toc tputs "

# $data

" lappend toc "-$data" } if { [catch { set path "[regsub -all {/+} "$env(PATH_INFO)" "/"]" rputs "Content-Type: text/html" if { "$path" == "/" } { add_toc "Tcl Information" tputs "" tputs " " tputs " " tputs " " tputs " " tputs " " tputs " " tputs " " tputs " " tputs "
" tputs " Version" tputs " " tputs " $tcl_version" tputs "
" tputs " Platform" tputs " " tputs " $tcl_platform(os)/$tcl_platform(machine) $tcl_platform(osVersion)" tputs "
" add_toc "Components" loop_components { if { [llength [info procs "${name}_info"]] > 0 } { ${name}_info } } set has_projects 0 add_toc "Projects" open_projects scan_projects { upvar 1 has_projects has_projects if { "$has_projects" == "0" } { set has_projects 1 tputs "" } tputs "" tputs " " tputs " " tputs "" } close_projects if { "$has_projects" == "1" } { tputs "
$name$description
" } else { tputs "No projects have been added, yet." } rputs "" start_html "Main" 1 rputs "$content" end_html 1 } elseif { [regexp {^/rpc.*$} "$path"] } { } elseif { [regexp {^/project/[^/]+.*$} "$path"] } { regexp {^/project/([^/]+).*$} "$path" -> projname open_projects set has_project [project_exists "$projname"] close_projects if { "$has_project" != "" } { add_toc "Description" tputs "[html_escape "$has_project"]" rputs "" start_html "Project: $projname" 1 rputs "$content" end_html 1 } else { tputs "I could not find the project you were finding." rputs "Status: 404 Not Found" rputs "" start_html "Not Found" 0 rputs "$content" end_html 0 } } else { tputs "I could not find the content you were finding." rputs "Status: 404 Not Found" rputs "" start_html "Not Found" 0 rputs "$content" end_html 0 } }] } { crash "Could not render the HTML" } else { puts "$result" } exiting 0