File: Httpd.tcl

package info (click to toggle)
coccinella 0.96.20-9
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 13,184 kB
  • sloc: tcl: 124,744; xml: 206; makefile: 66; sh: 62
file content (88 lines) | stat: -rw-r--r-- 2,686 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
#  Httpd.tcl ---
#  
#       This file is part of The Coccinella application. 
#       It is a wrapper for tinyhttpd.
#      
#  Copyright (c) 2004  Mats Bengtsson
#  
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#   
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#   
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see <http://www.gnu.org/licenses/>.
#  
# $Id: Httpd.tcl,v 1.7 2007-09-14 08:11:46 matben Exp $
    
package provide Httpd 1.0

namespace eval ::Httpd:: { 

    ::hooks::register initHook  ::Httpd::InitHook
}

proc ::Httpd::InitHook {} {
    global  prefs this auto_path
    
    # Start httpd thread. It enters its event loop if created without a sript.
    if {$this(package,Thread)} {
	set this(httpdthreadid) [thread::create]
	thread::send $this(httpdthreadid) [list set auto_path $auto_path]
    }
    
    # The 'tinyhttpd' package must be loaded in its threads interpreter if exists.
    if {$this(package,Thread)} {
	thread::send $this(httpdthreadid) {package require tinyhttpd}
    } else {
	package require tinyhttpd
    }
    
    # And start server.
    Httpd
}

proc ::Httpd::Httpd {} {
    global  prefs this
    
    ::Debug 2 "::Httpd::Httpd"
    
    # Start the tinyhttpd server, in its own thread if available.
    
    if {$prefs(haveHttpd)} {
	set script [list ::tinyhttpd::start -port $prefs(httpdPort)  \
	  -rootdirectory $this(httpdRootPath)]
	
	# For security we don't allow directory listings by default.
	if {$::debugLevel > 0} {
	    lappend script -directorylisting 1
	}
	
	if {[catch {
	    if {$this(package,Thread)} {
		thread::send $this(httpdthreadid) $script
		
		# Add more Mime types than the standard built in ones.
		thread::send $this(httpdthreadid)  \
		  [list ::tinyhttpd::addmimemappings [::Types::GetSuffMimeArr]]
	    } else {
		eval $script
		::tinyhttpd::addmimemappings [::Types::GetSuffMimeArr]
	    }
	} msg]} {
	    ::UI::MessageBox -icon error -title [mc "Error"] -type ok \
	      -message [mc "Cannot start the internal HTTP server: %s" $msg]
	} else {
	    
	    # Stop before quitting.
	    ::hooks::register quitAppHook ::tinyhttpd::stop
	}
    }
}
    
#-------------------------------------------------------------------------------