1# $Id: Invoker.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $
2
3package provide xotcl::actiweb::invoker 0.8
4
5package require XOTcl
6
7namespace eval ::xotcl::actiweb::invoker {
8    namespace import ::xotcl::*
9
10    Class AbstractInvoker
11    AbstractInvoker abstract instproc invokeCall {o method arguments}
12    AbstractInvoker abstract instproc eval {obj method arguments}
13    #
14    # error types are: tclError, invocationError
15    #
16    AbstractInvoker abstract instproc callError {type msg obj arguments} 
17
18    Class Invoker -superclass AbstractInvoker -parameter {{place [self]}}
19
20    Invoker instproc handleException {response} {
21	if {[my isExceptionObject $response]} {
22	    set exceptionObj $response
23	    switch [$exceptionObj info class] {
24		::RedirectException {
25		    set obj [$exceptionObj obj]
26		    set method [$exceptionObj method]
27		    set arguments [$exceptionObj arguments]
28		    set response [my eval $obj $method $arguments]
29		}
30		::ErrorException {
31		    set response [$exceptionObj set errorText]
32		}
33	    }
34	    $exceptionObj destroy
35	}
36	return $response
37    }
38
39    Invoker instproc invokeCall {o s method arguments} {
40	upvar [self callinglevel] $o obj $s status
41	my instvar place
42	set response ""
43	if {[$place isExportedObj $obj]} {
44	    # if method is not given -> call default on the object
45	    if {$method eq ""} {
46		set method default
47	    }
48	    if {[$obj isExportedProc $method]} {
49		#puts stderr "ExportedProcs of $obj: [$obj exportedProcs]"
50		#puts stderr "Call: $obj -- $method -- $arguments"
51		set response [my eval $obj $method $arguments]
52	    } else {
53		#puts stderr "ExportedProcs of $obj: [$obj exportedProcs]"
54		set response [my callError invocationError [$place startingObj] \
55				  "Method not found or not exported" \
56				  "$obj $method $arguments"]
57		set status 405
58	    }
59	} else {
60	    set called $obj
61	    set obj [$place startingObj]
62	    set response [my callError invocationError $obj \
63			      "Object '$called' unknown" ""]
64	    set status 404
65	}
66	
67	return [my handleException $response]
68    }
69
70    #
71    # tests whether "name" is an exception object or not
72    #
73    Invoker instproc isExceptionObject name {
74	if {[Object isobject $name] && [$name istype Exception]} {
75	    return 1
76	}
77	return 0
78    }
79
80    #
81    # central eval  -- all remote call
82    # are invoked through this method
83    #
84    Invoker instproc eval {obj method arguments} {
85	puts stderr "[clock format [clock seconds] \
86	-format %Y/%m/%d@%H:%M:%S] \
87	Eval Call: $obj $method $arguments"
88	if {[catch {
89	    set r [::eval $obj $method $arguments]
90	} ei]} {
91	    set r [my callError tclError $obj $ei "$obj $method $::errorInfo"]
92	}
93	return $r
94    }
95
96    Invoker instproc callError {type obj msg arguments} {
97	[my set place]::error $type $obj $msg $arguments
98    }
99
100    Class ErrorMgr
101    ErrorMgr instproc isHtml o {
102	if {[my isobject $o]} {
103	    if {[$o exists contentType]} {
104		if {[$o set contentType] eq "text/html"} {
105		    return 1
106		}
107	    }
108	}
109	return 0
110    }
111
112    ErrorMgr instproc invocationError {obj msg arguments} {
113	my showCall
114	set ee [ErrorException [self]::[my autoname ee]]
115	$ee instvar errorText
116	if {[my isHtml $obj]} {
117	    set errorText "<p> invocation error: $msg"
118	    if {[llength $arguments] > 0} {
119		append errorText ":\n<p> object: '[lindex $arguments 0]' \n"
120	    } else {
121		append errorText \n
122	    }
123	    if {[llength $arguments] > 1} {
124		append errorText "<p> call: '[lrange $arguments 1 end]' \n"
125	    }
126	} else {
127	    set errorText "invocation error: $msg $arguments"
128	}
129	return $ee
130    }
131
132    ErrorMgr instproc tclError {obj msg arguments} {
133	set ee [ErrorException [self]::[my autoname ee]]
134	if {[my isHtml $obj]} {
135	    $ee errorText "<p>tcl error: '$msg' \n<code><p><pre>$arguments</pre></code>"
136	} else {
137	    $ee errorText "tcl error: '$msg'\n$::errorInfo"
138	}
139	return $ee
140    }
141
142    #
143    # exceptions in invocation behavior
144    #
145    Class Exception
146    #
147    # Execpetion that tells the invoker to redirect the call to
148    # parameters
149    #
150    Class RedirectException -superclass Exception -parameter {
151	{obj ""}
152	{method ""}
153	{arguments ""}
154    }
155
156    Class ErrorException -superclass Exception -parameter {
157	{errorText ""}
158    }
159
160    namespace export AbstractInvoker \
161	Invoker ErrorMgr Exception \
162	RedirectException ErrorException
163}
164
165namespace import ::xotcl::actiweb::invoker::*
166