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