line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#main framework object |
2
|
|
|
|
|
|
|
package PSGI::Hector; |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
=pod |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
=head1 NAME |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
PSGI::Hector - Very simple PSGI web framework |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=head1 SYNOPSIS |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
my $app = App->init({ |
13
|
|
|
|
|
|
|
'responsePlugin' => 'Some::Class', |
14
|
|
|
|
|
|
|
}); |
15
|
|
|
|
|
|
|
########################### |
16
|
|
|
|
|
|
|
########################### |
17
|
|
|
|
|
|
|
package App; |
18
|
|
|
|
|
|
|
use PSGI::Hector; |
19
|
|
|
|
|
|
|
use parent qw(PSGI::Hector); |
20
|
|
|
|
|
|
|
########################### |
21
|
|
|
|
|
|
|
sub handleDefault{ |
22
|
|
|
|
|
|
|
#add code here for landing page |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
=head1 DESCRIPTION |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
All action subs are passed a L object as the only parameter, from this you should be able to reach |
28
|
|
|
|
|
|
|
everything you need. |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
=head1 METHODS |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=cut |
33
|
|
|
|
|
|
|
|
34
|
5
|
|
|
5
|
|
75158
|
use strict; |
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
128
|
|
35
|
5
|
|
|
5
|
|
19
|
use warnings; |
|
5
|
|
|
|
|
5
|
|
|
5
|
|
|
|
|
151
|
|
36
|
5
|
|
|
5
|
|
19
|
use File::Basename; |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
471
|
|
37
|
5
|
|
|
5
|
|
2236
|
use Class::Load qw(is_class_loaded); |
|
5
|
|
|
|
|
85460
|
|
|
5
|
|
|
|
|
312
|
|
38
|
5
|
|
|
5
|
|
2199
|
use parent qw(PSGI::Hector::Base PSGI::Hector::Utils); |
|
5
|
|
|
|
|
1184
|
|
|
5
|
|
|
|
|
24
|
|
39
|
5
|
|
|
5
|
|
1695
|
use PSGI::Hector::Response; |
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
119
|
|
40
|
5
|
|
|
5
|
|
1574
|
use PSGI::Hector::Session; #for session management |
|
5
|
|
|
|
|
9
|
|
|
5
|
|
|
|
|
126
|
|
41
|
5
|
|
|
5
|
|
1575
|
use PSGI::Hector::Request; |
|
5
|
|
|
|
|
12
|
|
|
5
|
|
|
|
|
140
|
|
42
|
5
|
|
|
5
|
|
1537
|
use PSGI::Hector::Log; |
|
5
|
|
|
|
|
7
|
|
|
5
|
|
|
|
|
3078
|
|
43
|
|
|
|
|
|
|
our $VERSION = "1.9"; |
44
|
|
|
|
|
|
|
######################################################### |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
=head2 init(\%options) |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
my $options = { |
49
|
|
|
|
|
|
|
'responsePlugin' => 'Some::Class', |
50
|
|
|
|
|
|
|
'checkReferer' => 0, |
51
|
|
|
|
|
|
|
'sessionClass' => 'Some::Class', |
52
|
|
|
|
|
|
|
'requestClass' => 'Some::Class', |
53
|
|
|
|
|
|
|
'sefUrls' => 0, |
54
|
|
|
|
|
|
|
'debug' => 1 |
55
|
|
|
|
|
|
|
}; |
56
|
|
|
|
|
|
|
my $h = PSGI::Hector->init($options); |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
Factory class method, used in creating the application from the F file. The return value |
59
|
|
|
|
|
|
|
from this method can be used where ever $app would be used. |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
This hash reference passed to the method contains any general options for the framework. |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
=cut |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
######################################################### |
66
|
|
|
|
|
|
|
sub init{ |
67
|
1
|
|
|
1
|
1
|
145
|
my($class, $options) = @_; |
68
|
|
|
|
|
|
|
return sub { |
69
|
0
|
|
|
0
|
|
0
|
my $env = shift; |
70
|
0
|
|
|
|
|
0
|
my $h = $class->new($options, $env); |
71
|
0
|
|
|
|
|
0
|
return $h->run(); #do this thing! |
72
|
1
|
|
|
|
|
5
|
}; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
######################################################### |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=head2 new(\%options, \%env) |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
my $options = {}; |
79
|
|
|
|
|
|
|
my $h = PSGI::Hector->new($options, $env); |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
Constructor, requires a hash references of options to be passed and the PSGI environment. |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
Usually this method is invoked from the init() class method. |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
=cut |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
######################################################### |
88
|
|
|
|
|
|
|
sub new{ |
89
|
5
|
|
|
5
|
1
|
878
|
my($class, $options, $env) = @_; |
90
|
5
|
50
|
|
|
|
16
|
if($options->{'responsePlugin'}){ #this option is mandatory |
91
|
5
|
|
|
|
|
39
|
my $self = $class->SUPER::new(); |
92
|
5
|
|
|
|
|
24
|
$self->{'_env'} = $env; |
93
|
5
|
|
|
|
|
7
|
$self->{'_options'} = $options; |
94
|
5
|
|
|
|
|
17
|
my $requestClass = $self->__getFullClassName("Request"); |
95
|
5
|
50
|
|
|
|
16
|
if($self->getOption('requestClass')){ |
96
|
0
|
|
|
|
|
0
|
$requestClass = $self->getOption('requestClass'); |
97
|
|
|
|
|
|
|
} |
98
|
5
|
100
|
|
|
|
13
|
if(!defined($self->getOption('debug'))){ #turn off debugging by default |
99
|
2
|
|
|
|
|
5
|
$self->_setOption("debug", 0); |
100
|
|
|
|
|
|
|
} |
101
|
5
|
|
|
|
|
40
|
$self->{'_request'} = $requestClass->new($env); |
102
|
5
|
|
|
|
|
48
|
$self->{'_response'} = PSGI::Hector::Response->new($self, $self->getOption('responsePlugin')); #this could need access to a request object |
103
|
5
|
|
|
|
|
20
|
$self->{'_log'} = PSGI::Hector::Log->new({ |
104
|
|
|
|
|
|
|
'debug' => $self->getOption('debug') |
105
|
|
|
|
|
|
|
}); |
106
|
5
|
|
|
|
|
23
|
$self->_init(); #perform initial setup |
107
|
5
|
|
|
|
|
17
|
return $self; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
else{ |
110
|
0
|
|
|
|
|
0
|
die("No response plugin option provided"); |
111
|
|
|
|
|
|
|
} |
112
|
0
|
|
|
|
|
0
|
return undef; |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
######################################################### |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
=pod |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
=head2 getResponse() |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
my $response = $h->getResponse(); |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Returns the current instance of the response plugin object, previously defined in the constructor options. |
123
|
|
|
|
|
|
|
See L for more details. |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
=cut |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
########################################################### |
128
|
|
|
|
|
|
|
sub getResponse{ |
129
|
7
|
|
|
7
|
1
|
932
|
my $self = shift; |
130
|
7
|
|
|
|
|
14
|
return $self->{'_response'}; |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
######################################################### |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
=pod |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
=head2 getSession() |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
my $session = $h->getSession(); |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
Returns the current instance of the L object. |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
=cut |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
########################################################### |
145
|
|
|
|
|
|
|
sub getSession{ |
146
|
1
|
|
|
1
|
1
|
383
|
my $self = shift; |
147
|
1
|
50
|
|
|
|
4
|
if(!$self->{'_session'}){ |
148
|
1
|
|
|
|
|
3
|
my $sessionClass = $self->__getFullClassName("Session"); |
149
|
1
|
50
|
|
|
|
12
|
if($self->getOption('sessionClass')){ |
150
|
0
|
|
|
|
|
0
|
$sessionClass = $self->getOption('sessionClass'); |
151
|
|
|
|
|
|
|
} |
152
|
1
|
|
|
|
|
6
|
$self->{'_session'} = $sessionClass->new($self); |
153
|
|
|
|
|
|
|
} |
154
|
1
|
|
|
|
|
2
|
return $self->{'_session'}; |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
######################################################### |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=pod |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
=head2 getRequest() |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
my $request = $h->getRequest(); |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
Returns the current instance of the L object. |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
=cut |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
########################################################### |
169
|
|
|
|
|
|
|
sub getRequest{ |
170
|
7
|
|
|
7
|
1
|
223
|
my $self = shift; |
171
|
7
|
|
|
|
|
38
|
my $request = $self->{'_request'}; |
172
|
7
|
50
|
|
|
|
34
|
if(!$request){ |
173
|
0
|
|
|
|
|
0
|
die("No request object found"); |
174
|
|
|
|
|
|
|
} |
175
|
7
|
|
|
|
|
18
|
return $request; |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
######################################################### |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
=pod |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=head2 getLog() |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
my $logger = $h->getLog(); |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
returns an current instance of the L object. |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
=cut |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
######################################################### |
190
|
|
|
|
|
|
|
sub getLog{ |
191
|
3
|
|
|
3
|
1
|
229
|
return shift->{'_log'}; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
######################################################### |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
=pod |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
=head2 getAction() |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
my $action = $h->getAction(); |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
Returns the curent action that the web application is performing. This is the current value of the "action" |
202
|
|
|
|
|
|
|
request form field or query string item. |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
If search engine friendly URLs are turned on the action will be determined from the last part of the script URL. |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
=cut |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
########################################################### |
209
|
|
|
|
|
|
|
sub getAction{ |
210
|
1
|
|
|
1
|
1
|
2
|
my $self = shift; |
211
|
1
|
|
|
|
|
1
|
my $action = "default"; |
212
|
1
|
|
|
|
|
4
|
my $request = $self->getRequest(); |
213
|
1
|
|
|
|
|
5
|
my $params = $request->getParameters(); |
214
|
1
|
50
|
|
|
|
127
|
if(defined($params->{'action'})){ #get action from query string or post string |
215
|
0
|
|
|
|
|
0
|
$action = $params->{'action'}; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
else{ #do we have search engine friendly urls |
218
|
1
|
|
|
|
|
4
|
my $sefAction = $self->_getSefAction(); |
219
|
1
|
50
|
|
|
|
3
|
if($sefAction){ |
220
|
0
|
|
|
|
|
0
|
$action = $sefAction; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
} |
223
|
1
|
|
|
|
|
3
|
return $action; |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
######################################################### |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
=pod |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
=head2 getUrlForAction($action, $queryString) |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
my $url = $h->getUrlForAction("someAction", "a=b&c=d"); |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
Returns the URL for the application with the given action and query string. |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
=cut |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
######################################################### |
238
|
|
|
|
|
|
|
sub getUrlForAction{ |
239
|
2
|
|
|
2
|
1
|
342
|
my($self, $action, $query) = @_; |
240
|
2
|
|
|
|
|
4
|
my $url = "/" . $action; |
241
|
2
|
50
|
|
|
|
4
|
if($query){ #add query string |
242
|
2
|
|
|
|
|
5
|
$url .= "?" . $query; |
243
|
|
|
|
|
|
|
} |
244
|
2
|
|
|
|
|
8
|
return $url; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
######################################################### |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
=pod |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
=head2 getFullUrlForAction($action, $queryString) |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
my $url = $h->getFullUrlForAction("someAction", "a=b&c=d"); |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
Returns the Full URL for the application with the given action and query string and hostname. |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
=cut |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
######################################################### |
259
|
|
|
|
|
|
|
sub getFullUrlForAction{ |
260
|
1
|
|
|
1
|
1
|
2
|
my($self, $action, $query) = @_; |
261
|
1
|
|
|
|
|
3
|
$self->getSiteUrl() . $self->getUrlForAction($action, $query); |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
######################################################### |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
=pod |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
=head2 run() |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
$h->run(); |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
This methood is required for the web application to deal with the current request. |
272
|
|
|
|
|
|
|
It should be called after any setup is done. |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
If the response object decides that the response has not been modified then this |
275
|
|
|
|
|
|
|
method will not run any action functions. |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
The action sub run will be determined by first checking the actions hash if previously |
278
|
|
|
|
|
|
|
given to the object then by checking if a method prefixed with "handle" exists in the |
279
|
|
|
|
|
|
|
current class. |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
=cut |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
########################################################### |
284
|
|
|
|
|
|
|
sub run{ #run the code for the given action |
285
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
286
|
0
|
|
|
|
|
0
|
my $response = $self->getResponse(); |
287
|
0
|
0
|
|
|
|
0
|
if($response->code() != 304){ #need to do something |
288
|
0
|
|
|
|
|
0
|
$self->getLog()->log("Need to run action sub", 'debug'); |
289
|
0
|
|
|
|
|
0
|
my $action = $self->getAction(); |
290
|
0
|
|
|
|
|
0
|
$self->getLog()->log("Using action: '$action'", 'debug'); |
291
|
0
|
|
|
|
|
0
|
my $subName = "handle" . ucfirst($action); #add prefix for security |
292
|
0
|
|
|
|
|
0
|
my $class = ref($self); |
293
|
0
|
0
|
|
|
|
0
|
if($class->can($subName)){ #default action sub exists |
294
|
0
|
|
|
|
|
0
|
eval{ |
295
|
0
|
|
|
|
|
0
|
$self->$subName(); |
296
|
|
|
|
|
|
|
}; |
297
|
0
|
0
|
|
|
|
0
|
if($@){ #problem with sub |
298
|
0
|
|
|
|
|
0
|
$response->setError($@); |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
else{ #no code to execute |
302
|
0
|
|
|
|
|
0
|
$response->code(404); |
303
|
0
|
|
|
|
|
0
|
$response->message('Not Found'); |
304
|
0
|
|
|
|
|
0
|
$response->setError("No action found for: $action"); |
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
} |
307
|
0
|
|
|
|
|
0
|
return $response->display(); #display the output to the browser |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
########################################################## |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
=pod |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=head2 getOption("key") |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
my $value = $h->getOption("debug"); |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
Returns the value of the configuration option given. |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
=cut |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
########################################################## |
322
|
|
|
|
|
|
|
sub getOption{ |
323
|
28
|
|
|
28
|
1
|
384
|
my($self, $key) = @_; |
324
|
28
|
|
|
|
|
24
|
my $value = undef; |
325
|
28
|
100
|
|
|
|
65
|
if(defined($self->{'_options'}->{$key})){ #this config option has been set |
326
|
15
|
|
|
|
|
23
|
$value = $self->{'_options'}->{$key}; |
327
|
|
|
|
|
|
|
} |
328
|
28
|
|
|
|
|
133
|
return $value; |
329
|
|
|
|
|
|
|
} |
330
|
|
|
|
|
|
|
########################################################## |
331
|
|
|
|
|
|
|
sub getEnv{ |
332
|
12
|
|
|
12
|
0
|
14
|
my $self = shift; |
333
|
12
|
|
|
|
|
25
|
return $self->{'_env'}; |
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
########################################################### |
336
|
|
|
|
|
|
|
# Private methods |
337
|
|
|
|
|
|
|
######################################################### |
338
|
|
|
|
|
|
|
sub __getFullClassName{ |
339
|
6
|
|
|
6
|
|
9
|
my($self, $name) = @_; |
340
|
5
|
|
|
5
|
|
21
|
no strict 'refs'; |
|
5
|
|
|
|
|
5
|
|
|
5
|
|
|
|
|
1750
|
|
341
|
6
|
|
|
|
|
11
|
my $class = ref($self); |
342
|
6
|
|
|
|
|
8
|
my $baseClass = @{$class . "::ISA"}[0]; #get base classes |
|
6
|
|
|
|
|
27
|
|
343
|
6
|
|
|
|
|
13
|
my $full = $baseClass . "::" . $name; #default to base class |
344
|
6
|
50
|
|
|
|
28
|
if(is_class_loaded($class . "::" . $name)){ |
345
|
6
|
|
|
|
|
359
|
$full = $class . "::" . $name |
346
|
|
|
|
|
|
|
} |
347
|
6
|
|
|
|
|
13
|
return $full; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
######################################################### |
350
|
|
|
|
|
|
|
sub __getActionDigest{ |
351
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
352
|
0
|
|
|
|
|
0
|
my $sha1 = Digest::SHA1->new(); |
353
|
0
|
|
|
|
|
0
|
$sha1->add($self->getAction()); |
354
|
0
|
|
|
|
|
0
|
return $sha1->hexdigest(); |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
########################################################### |
357
|
|
|
|
|
|
|
sub _getSefAction{ |
358
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
359
|
1
|
|
|
|
|
1
|
my $action = undef; |
360
|
1
|
|
|
|
|
2
|
my $env = $self->getEnv(); |
361
|
1
|
50
|
33
|
|
|
5
|
if(defined($env->{'PATH_INFO'}) && $env->{'PATH_INFO'} =~ m/\/(.+)$/){ #get the action from the last part of the url |
362
|
0
|
|
|
|
|
0
|
$action = $1; |
363
|
|
|
|
|
|
|
} |
364
|
1
|
|
|
|
|
1
|
return $action; |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
########################################################### |
367
|
|
|
|
|
|
|
sub _init{ #things to do when this object is created |
368
|
5
|
|
|
5
|
|
7
|
my $self = shift; |
369
|
5
|
50
|
33
|
|
|
18
|
if(!defined($self->getOption('checkReferer')) || $self->getOption('checkReferer')){ #check the referer by default |
370
|
5
|
|
|
|
|
14
|
$self->_checkReferer(); #check this first |
371
|
|
|
|
|
|
|
} |
372
|
5
|
|
|
|
|
24
|
return 1; |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
########################################################### |
375
|
|
|
|
|
|
|
sub _checkReferer{ #simple referer check for very basic security |
376
|
5
|
|
|
5
|
|
6
|
my $self = shift; |
377
|
5
|
|
|
|
|
8
|
my $result = 0; |
378
|
5
|
|
|
|
|
12
|
my $env = $self->getEnv(); |
379
|
5
|
|
|
|
|
10
|
my $host = $env->{'HTTP_HOST'}; |
380
|
5
|
50
|
33
|
|
|
173
|
if($host && $env->{'HTTP_REFERER'} && $env->{'HTTP_REFERER'} =~ m/^(http|https):\/\/$host/){ #simple check here |
|
|
|
33
|
|
|
|
|
381
|
5
|
|
|
|
|
6
|
$result = 1; |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
else{ |
384
|
0
|
|
|
|
|
0
|
my $response = $self->getResponse(); |
385
|
0
|
|
|
|
|
0
|
$response->setError("Details where not sent from the correct web page"); |
386
|
|
|
|
|
|
|
} |
387
|
5
|
|
|
|
|
13
|
return $result; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
########################################################## |
390
|
|
|
|
|
|
|
sub _getActions{ |
391
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
392
|
0
|
|
|
|
|
0
|
return $self->{'_actions'}; |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
########################################################### |
395
|
|
|
|
|
|
|
sub _setOption{ |
396
|
2
|
|
|
2
|
|
5
|
my($self, $key, $value) = @_; |
397
|
2
|
|
|
|
|
4
|
$self->{'_options'}->{$key} = $value; |
398
|
2
|
|
|
|
|
3
|
return 1; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
########################################################## |
401
|
|
|
|
|
|
|
sub _getScriptName{ #returns the basename of the running script |
402
|
0
|
|
|
0
|
|
|
my $self = shift; |
403
|
0
|
|
|
|
|
|
my $env = $self->getEnv(); |
404
|
0
|
|
|
|
|
|
my $scriptName = $env->{'REQUEST_URI'}; |
405
|
0
|
0
|
|
|
|
|
if($scriptName){ |
406
|
0
|
|
|
|
|
|
return basename($scriptName); |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
else{ |
409
|
0
|
|
|
|
|
|
die("Cant find scriptname, are you running a CGI"); |
410
|
|
|
|
|
|
|
} |
411
|
0
|
|
|
|
|
|
return undef; |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
########################################################### |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
=pod |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
=head1 CONFIGURATION SUMMARY |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
The following list gives a summary of each Hector |
420
|
|
|
|
|
|
|
configuration options. |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
=head3 responsePlugin |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
A scalar string consisting of the response class to use. |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
See L for details on how to create your own response class, or |
427
|
|
|
|
|
|
|
a list of response classes provided in this package. |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
=head3 checkReferer |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
Flag to indicate if referer checking should be performed. When enabled an |
432
|
|
|
|
|
|
|
error will raised when the referer is not present or does not contain the server's |
433
|
|
|
|
|
|
|
hostname. |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
This option is enabled by default. |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
=head3 sessionClass |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
A scalar string consisting of the session class to use. Useful if you want to change the way |
440
|
|
|
|
|
|
|
session are stored. |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
Defaults to ref($self)::Session |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
=head3 requestClass |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
A scalar string consisting of the request class to use. Useful if you want to change the way |
447
|
|
|
|
|
|
|
requests are handled. |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
Defaults to ref($self)::Request |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
=head3 sefUrls |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
A boolean value indicating if search engine friendly URLs are to be used. |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
=head3 debug |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
A boolean value indicating if debug mode is enabled. This can then be used in output views or code to print extra debug. |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
=head1 Notes |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
To change the session prefix characters use the following code at the top of your script: |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
$PSGI::Hector::Session::prefix = "ABC"; |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
To change the session file save path use the following code at the top of your script: |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
$PSGI::Hector::Session::path = "/var/tmp"; |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
=head2 Reverse proxies |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
To run your application behind a reverse proxy using apache, please use the following setup: |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
RequestHeader set X-Forwarded-Script-Name /psgi |
475
|
|
|
|
|
|
|
RequestHeader set X-Traversal-Path / |
476
|
|
|
|
|
|
|
ProxyPass http://localhost:8080/ |
477
|
|
|
|
|
|
|
ProxyPassReverse http://localhost:8080/ |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
=head1 Author |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
MacGyveR |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
Development questions, bug reports, and patches are welcome to the above address |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
=head1 See Also |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
=head1 Copyright |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
Copyright (c) 2017 MacGyveR. All rights reserved. |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
=cut |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
########################################################### |
497
|
|
|
|
|
|
|
return 1; |