line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package CGI::Panel; |
2
|
1
|
|
|
1
|
|
729
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
36
|
|
3
|
1
|
|
|
1
|
|
2105
|
use CGI; |
|
1
|
|
|
|
|
18062
|
|
|
1
|
|
|
|
|
6
|
|
4
|
1
|
|
|
1
|
|
866
|
use CGI::Carp 'fatalsToBrowser'; |
|
1
|
|
|
|
|
2296
|
|
|
1
|
|
|
|
|
10
|
|
5
|
1
|
|
|
1
|
|
857
|
use Apache::Session::File; |
|
1
|
|
|
|
|
24900
|
|
|
1
|
|
|
|
|
30
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
BEGIN { |
8
|
1
|
|
|
1
|
|
8
|
use Exporter (); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
18
|
|
9
|
1
|
|
|
1
|
|
3
|
use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
83
|
|
10
|
1
|
|
|
1
|
|
3
|
$VERSION = 0.97; |
11
|
1
|
|
|
|
|
12
|
@ISA = qw (Exporter); |
12
|
1
|
|
|
|
|
2
|
@EXPORT = qw (); |
13
|
1
|
|
|
|
|
1
|
@EXPORT_OK = qw (); |
14
|
1
|
|
|
|
|
2910
|
%EXPORT_TAGS = (); |
15
|
|
|
|
|
|
|
} |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
########################################### main pod documentation begin ## |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
=head1 NAME |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
CGI::Panel - Create stateful event-driven web applications from simple panel objects |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
=head1 SYNOPSIS |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
A very simple working application consisting of a driver cgi and two panel classes... |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
In simpleapp.cgi: |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
use SimpleApp; |
30
|
|
|
|
|
|
|
my $simple_app = obtain SimpleApp; |
31
|
|
|
|
|
|
|
$simple_app->cycle(); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
In SimpleApp.pm: |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
package SimpleApp; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
use base qw(CGI::Panel); |
38
|
|
|
|
|
|
|
use Basket; |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
sub init { |
41
|
|
|
|
|
|
|
my ($self) = @_; |
42
|
|
|
|
|
|
|
$self->add_panel('basket1', new Basket); # Add a sub-panel |
43
|
|
|
|
|
|
|
$self->add_panel('basket2', new Basket); # Add a sub-panel |
44
|
|
|
|
|
|
|
$self->add_panel('basket3', new Basket); # Add a sub-panel |
45
|
|
|
|
|
|
|
$self->{count} = 1; # Initialise some persistent data |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub _event_add { # Respond to the button click event below |
49
|
|
|
|
|
|
|
my ($self, $event) = @_; |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
$self->{count}++; # Change the persistent data |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
sub display { |
55
|
|
|
|
|
|
|
my ($self) = @_; |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
return |
58
|
|
|
|
|
|
|
'This is a very simple app. ' . |
59
|
|
|
|
|
|
|
# Display the persistent data... |
60
|
|
|
|
|
|
|
"My current count is $self->{count} " . |
61
|
|
|
|
|
|
|
# Display the sub-panels... |
62
|
|
|
|
|
|
|
"" .
63
|
|
|
|
|
|
|
" | " . $self->panel('basket1')->display . " | " .
64
|
|
|
|
|
|
|
" | " . $self->panel('basket2')->display . " | " .
65
|
|
|
|
|
|
|
" | " . $self->panel('basket3')->display . " | " .
66
|
|
|
|
|
|
|
" | " . |
67
|
|
|
|
|
|
|
# Display a button that will generate an event... |
68
|
|
|
|
|
|
|
$self->event_button(label => 'Add 1', name => 'add'); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
1; |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
In Basket.pm: |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
package Basket; |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
use base qw(CGI::Panel); |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
sub init { |
80
|
|
|
|
|
|
|
my ($self) = @_; |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
$self->{contents} = []; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub _event_add { # Respond to the button event in 'display' |
86
|
|
|
|
|
|
|
my ($self, $event) = @_; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
# Get panel's localised parameters |
89
|
|
|
|
|
|
|
# (Many instances of this panel each get |
90
|
|
|
|
|
|
|
# their own local parameters) |
91
|
|
|
|
|
|
|
my %local_params = $self->local_params; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
push @{$self->{contents}}, $local_params{item_name}; |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
sub display { |
97
|
|
|
|
|
|
|
my ($self) = @_; |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
return |
100
|
|
|
|
|
|
|
'' .
101
|
|
|
|
|
|
|
join('', (map { " | $_ | " } @{$self->{contents}})) .
102
|
|
|
|
|
|
|
' | ' .
103
|
|
|
|
|
|
|
# Localised text field |
104
|
|
|
|
|
|
|
' | ' . $self->local_textfield({name => 'item_name', size => 10}) . ' | ' .
105
|
|
|
|
|
|
|
# Button that will generate an event (handled by _event_add above) |
106
|
|
|
|
|
|
|
' | ' . $self->event_button(label => 'Add', name => 'add') . ' | ' .
107
|
|
|
|
|
|
|
' | ' .
108
|
|
|
|
|
|
|
' | '; |
109
|
|
|
|
|
|
|
}; |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
1; |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
This example is included with the module. It's in the 'demo' |
114
|
|
|
|
|
|
|
directory and can be seen in action at |
115
|
|
|
|
|
|
|
http://www.cyberdesignfactory.com/public-cgi-bin/simpleapp.cgi |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
=head1 DESCRIPTION |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
CGI::Panel allows applications to be built out of simple object-based |
120
|
|
|
|
|
|
|
components. It'll handle the state of your data and objects so you |
121
|
|
|
|
|
|
|
can write a web application just like a desktop app. You can forget |
122
|
|
|
|
|
|
|
about the http requests and responses, whether we're getting or |
123
|
|
|
|
|
|
|
posting, and all that stuff because that is all handled for you |
124
|
|
|
|
|
|
|
leaving to you interact with a simple API. |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
An application is constructed from a set of 'panels', each of which |
127
|
|
|
|
|
|
|
can contain other panels. The panels are managed behind the scenes |
128
|
|
|
|
|
|
|
as persistent objects. See the sample applications for examples of |
129
|
|
|
|
|
|
|
how complex object-based applications can be built from simple |
130
|
|
|
|
|
|
|
encapsulated components. To try the demo app, copy the contents of |
131
|
|
|
|
|
|
|
the 'demo' directory to a cgi-bin directory. |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
CGI::Panel allows you to design the logic of your application in an |
134
|
|
|
|
|
|
|
event-driven manner. That is, you set up your application the way |
135
|
|
|
|
|
|
|
you want it, with special buttons and links that trigger 'events'. |
136
|
|
|
|
|
|
|
The application then sits back and when an event is triggered, the |
137
|
|
|
|
|
|
|
code associated with that event is run. The code that responds to an |
138
|
|
|
|
|
|
|
event goes in the same class as the code that generates the event |
139
|
|
|
|
|
|
|
button or link, making the code more readable and maintainable. If |
140
|
|
|
|
|
|
|
the event code changes the state of any of the panels, the panels |
141
|
|
|
|
|
|
|
will then stay in the new state, until their state is changed again. |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
Each panel is encapsulated not only in terms of the code, but in |
144
|
|
|
|
|
|
|
terms of the form data that is passed through. For example a panel |
145
|
|
|
|
|
|
|
class can be defined which has a textfield called 'name'. Three |
146
|
|
|
|
|
|
|
instances of this panel can then exist simultaneously and each will |
147
|
|
|
|
|
|
|
get the correct value of the 'name' parameter when they read their |
148
|
|
|
|
|
|
|
parameters (see the 'local_params' method). |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
Please let me know by email if you're using the module and would |
151
|
|
|
|
|
|
|
like to be informed when there's an update. |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
=head1 USAGE |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
See 'SYNOPSIS' |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
=head1 BUGS |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
=head1 SUPPORT |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
=head1 AUTHOR |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
Robert J. Symes |
164
|
|
|
|
|
|
|
CPAN ID: RSYMES |
165
|
|
|
|
|
|
|
rob@robsymes.com |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
=head1 COPYRIGHT |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
Copyright (c) 2002 Robert J. Symes. All rights reserved. |
170
|
|
|
|
|
|
|
This program is free software; you can redistribute |
171
|
|
|
|
|
|
|
it and/or modify it under the same terms as Perl itself. |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
The full text of the license can be found in the |
174
|
|
|
|
|
|
|
LICENSE file included with this module. |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
=head1 SEE ALSO |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
perl(1). |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
=head1 PUBLIC METHODS |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
Each public function/method is described here. |
183
|
|
|
|
|
|
|
These are how you should interact with this module. |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
=cut |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
############################################# main pod documentation end ## |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
# Public methods and functions go here. |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
############################################################### |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
=head2 new |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
Creates a new panel object |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
Use: |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
my $panel = new Panel; |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
=cut |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
############################################################### |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
sub new |
208
|
|
|
|
|
|
|
{ |
209
|
0
|
|
|
0
|
1
|
|
my ($class, %args) = @_; |
210
|
|
|
|
|
|
|
|
211
|
0
|
|
|
|
|
|
my $panel = {}; |
212
|
|
|
|
|
|
|
|
213
|
0
|
|
|
|
|
|
bless $panel, $class; |
214
|
|
|
|
|
|
|
|
215
|
0
|
|
|
|
|
|
$panel->init; |
216
|
|
|
|
|
|
|
|
217
|
0
|
|
|
|
|
|
return $panel; |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
############################################################### |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=head2 init |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
Initialises a panel object. This should be used to add panels |
225
|
|
|
|
|
|
|
to the current panel. We provide a default method here which |
226
|
|
|
|
|
|
|
can be overridden. |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
Example: |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
sub init { |
231
|
|
|
|
|
|
|
my ($self) = @_; |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
$self->add_panel('first_panel', App::Panel::First); |
234
|
|
|
|
|
|
|
$self->add_panel('second_panel', App::Panel::Second); |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
=cut |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
############################################################### |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
sub init |
242
|
|
|
|
|
|
|
{ |
243
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
# No action for default init routine |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
############################################################### |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
=head2 parent |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
Get or set the parent of the panel object. |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
Examples: |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
my $parent = $self->parent; |
257
|
|
|
|
|
|
|
$self->parent($other_panel); |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
=cut |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
############################################################### |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
sub parent { |
264
|
0
|
|
|
0
|
1
|
|
my ($self, $parent) = @_; |
265
|
|
|
|
|
|
|
|
266
|
0
|
0
|
0
|
|
|
|
die "Parent not a panel object" |
267
|
|
|
|
|
|
|
if $parent && !($parent->isa('CGI::Panel')); |
268
|
0
|
0
|
|
|
|
|
$self->{_parent} = $parent if defined($parent); |
269
|
|
|
|
|
|
|
# die "No parent set" unless defined($self->{_parent}); |
270
|
|
|
|
|
|
|
|
271
|
0
|
|
|
|
|
|
return $self->{_parent}; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
############################################################### |
275
|
|
|
|
|
|
|
# We should remove this state method as it's unnecessary and confusing |
276
|
|
|
|
|
|
|
############################################################### |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
sub state { |
279
|
0
|
|
|
0
|
0
|
|
my ($self, $state) = @_; |
280
|
|
|
|
|
|
|
|
281
|
0
|
0
|
|
|
|
|
$self->{_state} = $state if defined($state); |
282
|
|
|
|
|
|
|
# croak "No state set" unless defined($self->{_state}); |
283
|
|
|
|
|
|
|
|
284
|
0
|
|
|
|
|
|
return $self->{_state}; |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
############################################################### |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
=head2 get_session_id |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
Gets the session id for the application |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
Note: It's essential that all panels are added using the |
294
|
|
|
|
|
|
|
proper add_panel routine for this routine to work correctly. |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
Example: |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
my $id = $self->get_session_id; |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
=cut |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
############################################################### |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
sub get_persistent_id { |
305
|
0
|
|
|
0
|
0
|
|
my ($self) = @_; |
306
|
|
|
|
|
|
|
|
307
|
0
|
|
|
|
|
|
warn "get_persistent id now called get_session_id - please rename"; |
308
|
|
|
|
|
|
|
|
309
|
0
|
|
|
|
|
|
$self->get_session_id |
310
|
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
sub get_session_id { |
313
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# If we're the main panel, return our stored session id |
316
|
0
|
0
|
|
|
|
|
return $self->{session_id} unless $self->parent; |
317
|
|
|
|
|
|
|
|
318
|
0
|
0
|
|
|
|
|
die "ERROR: No main panel found for get_session_id call" |
319
|
|
|
|
|
|
|
unless ref($self->main_panel); |
320
|
|
|
|
|
|
|
|
321
|
0
|
|
|
|
|
|
return $self->main_panel->get_session_id |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
############################################################### |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
=head2 panel |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
Retrieves a sub-panel by name |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
Example: |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
my $first_panel = $self->panel('first_panel'); |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
=cut |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
############################################################### |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
sub panel |
339
|
|
|
|
|
|
|
{ |
340
|
0
|
|
|
0
|
1
|
|
my ($self, $panel_name) = @_; |
341
|
|
|
|
|
|
|
|
342
|
0
|
|
|
|
|
|
confess "ERROR: No such panel ($panel_name)" |
343
|
|
|
|
|
|
|
. " - Can be caused by attaching unstorable " |
344
|
|
|
|
|
|
|
. "data to panel object\n" |
345
|
0
|
0
|
|
|
|
|
. "Available panels: " . join("\n", keys %{$self->{panels}}) |
346
|
|
|
|
|
|
|
unless $self->{panels}->{$panel_name}; |
347
|
|
|
|
|
|
|
|
348
|
0
|
|
|
|
|
|
return $self->{panels}->{$panel_name}; |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
############################################################### |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
=head2 get_panels |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
Retrieves the set of panels as a hash |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
Example: |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
my %panels = $self->get_panels; |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
=cut |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
############################################################### |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
sub get_panels { |
366
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
367
|
|
|
|
|
|
|
|
368
|
0
|
0
|
|
|
|
|
return $self->{panels} ? %{$self->{panels}} : (); |
|
0
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
############################################################### |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
=head2 get_id |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
Gets the id of the panel. |
376
|
|
|
|
|
|
|
If one is not currently stored, we generate a |
377
|
|
|
|
|
|
|
new one with help from the main panel. |
378
|
|
|
|
|
|
|
This method can be overridden if you want to give a unique name |
379
|
|
|
|
|
|
|
to a panel. |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
Examples: |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
sub get_id { 'unique_name' } |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
or |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
my $id = $self->get_id; |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
and later... |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
$self->get_panel_by_id('unique_name'); |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
or |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
$self->get_panel_by_id($id); |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
See documentation of get_panel_by_id for more details. (Of course, |
398
|
|
|
|
|
|
|
you can also just use this get_id to get the auto-generated id and |
399
|
|
|
|
|
|
|
use that later in get_panel_by_id.) |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
=cut |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
############################################################### |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
sub get_id { |
406
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
407
|
|
|
|
|
|
|
|
408
|
0
|
0
|
|
|
|
|
unless (defined($self->{id})) { |
409
|
0
|
|
|
|
|
|
my $main_panel = $self->main_panel; |
410
|
0
|
|
|
|
|
|
$self->{id} = $main_panel->register_panel($self); |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
0
|
|
|
|
|
|
return $self->{id}; |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
############################################################### |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
=head2 main_panel |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
Get the main panel (by recursing up the panel tree) |
421
|
|
|
|
|
|
|
Eventually this will reach a panel without a parent, |
422
|
|
|
|
|
|
|
which we will assume to be the main panel. |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
Example: |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
my $main_panel = $self->main_panel; |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
=cut |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
############################################################### |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
sub main_panel { |
433
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
# Return cached result if found |
436
|
0
|
0
|
|
|
|
|
return $self->{_main_panel} |
437
|
|
|
|
|
|
|
if $self->{_main_panel}; |
438
|
|
|
|
|
|
|
|
439
|
0
|
0
|
|
|
|
|
my $parent = $self->parent |
440
|
|
|
|
|
|
|
or return $self; |
441
|
|
|
|
|
|
|
|
442
|
0
|
|
|
|
|
|
$self->{_main_panel} = $parent->main_panel; |
443
|
0
|
|
|
|
|
|
return $self->{_main_panel}; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
############################################################### |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
=head2 add_panel |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
Adds a panel to the current panel in a way that maintains |
451
|
|
|
|
|
|
|
referential integrity, ie the child panel's parent value will |
452
|
|
|
|
|
|
|
be set to the current panel. All panels should be added to |
453
|
|
|
|
|
|
|
their parents using this routine to keep referential integrity |
454
|
|
|
|
|
|
|
and allow certain other mechanisms to work. |
455
|
|
|
|
|
|
|
Specify the name to refer to the panel by and the panel object. |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
Example: |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
$self->add_panel('first_panel', new App::Panel::First); |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
=cut |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
############################################################### |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
sub add_panel |
466
|
|
|
|
|
|
|
{ |
467
|
0
|
|
|
0
|
1
|
|
my ($self, $panel_name, $panel) = @_; |
468
|
|
|
|
|
|
|
|
469
|
0
|
|
|
|
|
|
$self->{panels}->{$panel_name} = $panel; |
470
|
0
|
|
|
|
|
|
$panel->parent($self); |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
############################################################### |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
=head2 remove_panels |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
Remove all the panels from the current panel. |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
Example: |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
$self->remove_panels; |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
=cut |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
############################################################### |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
sub remove_panels { |
488
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
489
|
|
|
|
|
|
|
|
490
|
0
|
|
|
|
|
|
$self->{panels} = {}; |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
############################################################### |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
=head2 local_params |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
Get the parameter list for the current panel. This fetches the |
498
|
|
|
|
|
|
|
parameter list and returns the parameters that are relevant to |
499
|
|
|
|
|
|
|
the current panel. This allows each panel to be written in |
500
|
|
|
|
|
|
|
isolation. Two panels may have input controls (textboxes etc) |
501
|
|
|
|
|
|
|
with the same name and they can each retrieve the value of |
502
|
|
|
|
|
|
|
that input from their %local_params hash. |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
eg |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
my %local_params = $self->local_params; |
507
|
|
|
|
|
|
|
my $name = $local_params{name}; |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
=cut |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
############################################################### |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
sub local_params |
514
|
|
|
|
|
|
|
{ |
515
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
516
|
|
|
|
|
|
|
|
517
|
0
|
|
|
|
|
|
my $cgi = new CGI; |
518
|
0
|
|
|
|
|
|
my $panel_id = $self->get_id; |
519
|
0
|
|
|
|
|
|
my %cgi_params = map { $_ => $cgi->param($_) } $cgi->param; |
|
0
|
|
|
|
|
|
|
520
|
0
|
|
|
|
|
|
my %local_params; |
521
|
|
|
|
|
|
|
|
522
|
0
|
|
|
|
|
|
foreach my $key (keys %cgi_params) { |
523
|
0
|
|
|
|
|
|
my $value = $cgi_params{$key}; |
524
|
0
|
0
|
|
|
|
|
if (my ($lp_panel_id, $lp_name) = split($self->SEPRE, $key)) { |
525
|
0
|
0
|
|
|
|
|
if ($lp_panel_id eq $panel_id) { |
526
|
0
|
|
|
|
|
|
$local_params{$lp_name} = $value; |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
|
531
|
0
|
|
|
|
|
|
return %local_params; |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
############################################################### |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
=head2 event_button |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
Display a button which when pressed re-cycles the application |
539
|
|
|
|
|
|
|
and generates an event to be handled by the next incarnation of |
540
|
|
|
|
|
|
|
the application. The name of the routine that will be called |
541
|
|
|
|
|
|
|
will have _event_ prepended. This is partly for aesthesic reasons |
542
|
|
|
|
|
|
|
but mainly for security, to stop a wily hacker from calling any |
543
|
|
|
|
|
|
|
routine by changing what is passed through the browser. We'll |
544
|
|
|
|
|
|
|
probably be encrypting what is passed through in a later version. |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
Input: |
547
|
|
|
|
|
|
|
label: Caption to display on button |
548
|
|
|
|
|
|
|
name: Name of the event |
549
|
|
|
|
|
|
|
routine: Name of the event routine to call |
550
|
|
|
|
|
|
|
(defaults to name value if not specified) |
551
|
|
|
|
|
|
|
('_event_' is prepended to the routine name) |
552
|
|
|
|
|
|
|
other_tags: Other tags for the html item |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
For example: |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
$shop->event_button( |
557
|
|
|
|
|
|
|
label => 'Add Item', |
558
|
|
|
|
|
|
|
name => 'add', |
559
|
|
|
|
|
|
|
routine => 'add', |
560
|
|
|
|
|
|
|
other_tags => { |
561
|
|
|
|
|
|
|
class => 'myclass' |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
); |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
=cut |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
############################################################### |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
sub event_button |
570
|
|
|
|
|
|
|
{ |
571
|
0
|
|
|
0
|
1
|
|
my ($self, %args) = @_; |
572
|
|
|
|
|
|
|
|
573
|
0
|
0
|
|
|
|
|
my $label = $args{label} |
574
|
|
|
|
|
|
|
or die "ERROR: event has no label"; |
575
|
0
|
0
|
|
|
|
|
my $name = $args{name} |
576
|
|
|
|
|
|
|
or die "ERROR: event has no event name"; |
577
|
0
|
|
|
|
|
|
my $panel_id = $self->get_id; |
578
|
0
|
|
0
|
|
|
|
my $routine = $args{routine} || $args{name}; # Default to name |
579
|
0
|
|
|
|
|
|
my $other_tags = $args{other_tags}; |
580
|
|
|
|
|
|
|
|
581
|
0
|
|
|
|
|
|
my $SEP = $self->SEP; |
582
|
0
|
|
|
|
|
|
my $n = "$name$SEP$routine$SEP$panel_id"; |
583
|
|
|
|
|
|
|
|
584
|
0
|
|
|
|
|
|
my $cgi = new CGI; |
585
|
|
|
|
|
|
|
|
586
|
0
|
|
|
|
|
|
my $args_hash = { |
587
|
|
|
|
|
|
|
label => $label, |
588
|
|
|
|
|
|
|
name => "eventbutton+$n", |
589
|
|
|
|
|
|
|
}; |
590
|
0
|
|
|
|
|
|
foreach my $other_tag (keys %$other_tags) { |
591
|
0
|
|
|
|
|
|
$args_hash->{$other_tag} = $other_tags->{$other_tag} |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
|
594
|
0
|
|
|
|
|
|
return $cgi->submit($args_hash); |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
# return $cgi->submit({ |
597
|
|
|
|
|
|
|
# label => $label, |
598
|
|
|
|
|
|
|
# name => "eventbutton+$n", |
599
|
|
|
|
|
|
|
# style => $style |
600
|
|
|
|
|
|
|
# }); |
601
|
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
############################################################### |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
=head2 event_link |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
Display a link (which can be an image link) which when pressed |
608
|
|
|
|
|
|
|
re-cycles the application and generates an event to be handled |
609
|
|
|
|
|
|
|
by the next incarnation of the application. |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
Input: |
612
|
|
|
|
|
|
|
label: Caption to display on link |
613
|
|
|
|
|
|
|
* OR * |
614
|
|
|
|
|
|
|
img: Image to display as link |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
name: Name of the event |
617
|
|
|
|
|
|
|
routine: Name of the event routine to call |
618
|
|
|
|
|
|
|
(defaults to name value if not specified) |
619
|
|
|
|
|
|
|
('_event_' is prepended to the routine name) |
620
|
|
|
|
|
|
|
other_tags: Other tags for the html item |
621
|
|
|
|
|
|
|
img_tags: Other tags for the image (if the link is an image) |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
For example: |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
$shop->event_link( |
626
|
|
|
|
|
|
|
label => 'Add Item', |
627
|
|
|
|
|
|
|
name => 'add', |
628
|
|
|
|
|
|
|
other_tags => { |
629
|
|
|
|
|
|
|
width => 20 |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
); |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
=cut |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
############################################################### |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
sub event_link |
638
|
|
|
|
|
|
|
{ |
639
|
0
|
|
|
0
|
1
|
|
my ($self, %args) = @_; |
640
|
|
|
|
|
|
|
|
641
|
0
|
|
|
|
|
|
my $label = $args{label}; |
642
|
0
|
|
|
|
|
|
my $img = $args{img}; |
643
|
0
|
0
|
0
|
|
|
|
croak "ERROR: event_link has neither a label nor an image" |
644
|
|
|
|
|
|
|
unless $label || $img; |
645
|
0
|
0
|
|
|
|
|
my $name = $args{name} |
646
|
|
|
|
|
|
|
or die "ERROR: event_link has no event name"; |
647
|
0
|
|
|
|
|
|
my $panel_id = $self->get_id; |
648
|
0
|
|
0
|
|
|
|
my $routine = $args{routine} || $args{name}; # Default to name |
649
|
0
|
|
|
|
|
|
my $other_tags = $args{other_tags}; |
650
|
0
|
|
|
|
|
|
my $img_tags = $args{img_tags}; |
651
|
0
|
|
|
|
|
|
my $cgi = new CGI; |
652
|
0
|
|
|
|
|
|
my $script_name = $cgi->script_name; |
653
|
|
|
|
|
|
|
|
654
|
0
|
|
|
|
|
|
my $session_id = $self->get_session_id; |
655
|
|
|
|
|
|
|
|
656
|
0
|
|
|
|
|
|
my $SEP = $self->SEP; |
657
|
0
|
|
|
|
|
|
my $n = "$name$SEP$routine$SEP$panel_id"; |
658
|
|
|
|
|
|
|
|
659
|
0
|
|
|
|
|
|
my $href = "$script_name?session_id=$session_id&n=$n"; |
660
|
0
|
|
|
|
|
|
my $args_hash = { |
661
|
|
|
|
|
|
|
href => $href, |
662
|
|
|
|
|
|
|
}; |
663
|
0
|
|
|
|
|
|
foreach my $other_tag (keys %$other_tags) { |
664
|
0
|
|
|
|
|
|
$args_hash->{$other_tag} = $other_tags->{$other_tag} |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
|
667
|
0
|
|
|
|
|
|
my $output; |
668
|
0
|
0
|
|
|
|
|
if ($label) { |
669
|
|
|
|
|
|
|
# $output = $cgi->a({href => $href}, $label); |
670
|
0
|
|
|
|
|
|
$output = $cgi->a($args_hash, $label); |
671
|
|
|
|
|
|
|
} |
672
|
|
|
|
|
|
|
else { |
673
|
0
|
|
|
|
|
|
my $img_args_hash = { |
674
|
|
|
|
|
|
|
src => $img, |
675
|
|
|
|
|
|
|
}; |
676
|
0
|
|
|
|
|
|
foreach my $img_tag (keys %$img_tags) { |
677
|
0
|
|
|
|
|
|
$img_args_hash->{$img_tag} = $img_tags->{$img_tag} |
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
# $output = $cgi->a($args_hash, $cgi->img({src => $img})); |
680
|
0
|
|
|
|
|
|
$output = $cgi->a($args_hash, $cgi->img($img_args_hash)); |
681
|
|
|
|
|
|
|
} |
682
|
|
|
|
|
|
|
|
683
|
0
|
|
|
|
|
|
return $output; |
684
|
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
############################################################### |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
=head2 CGI input functions |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
The CGI input functions are available here with local_ prepended |
691
|
|
|
|
|
|
|
so the name can be made panel-specific, and they can be called |
692
|
|
|
|
|
|
|
as a method. The same effect can be achieved by using the |
693
|
|
|
|
|
|
|
get_localised_name function for the name of the parameter. |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
Example: |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
$self->local_textfield({name => 'testinput', size => 40}) |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
is equivalent to: |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
my $cgi = new CGI; |
702
|
|
|
|
|
|
|
$cgi->textfield({name => $self->get_localised_name('testinput'), size => 40}) |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
Using these methods means that the panel will have exclusive |
705
|
|
|
|
|
|
|
access to the named input parameter. So to obtain the value of |
706
|
|
|
|
|
|
|
the input parameter above, we would write the following: |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
my %local_params = $self->local_params; |
709
|
|
|
|
|
|
|
my $test_input_value = $local_params{'testinput'}; |
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
Note that with this technique, several panels could have |
712
|
|
|
|
|
|
|
input controls with the same name and they will each receive |
713
|
|
|
|
|
|
|
the correct value. This is especially useful for sets of panels |
714
|
|
|
|
|
|
|
of the same class. |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
=cut |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
############################################################### |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
# Overridden functions |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
# May be able to combine these into one AUTOLOAD function |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
############################################################### |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
=head2 get_localised_name |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
Return a name that has the panel id encoded into it. This is |
729
|
|
|
|
|
|
|
used by the local_... functions and can be used to build a custom |
730
|
|
|
|
|
|
|
html input control that will deliver its value when the panel's |
731
|
|
|
|
|
|
|
local_params method is called. |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
Example: |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
$output .= $cgi->textfield({name => $self->get_localised_name('sometext')}); |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
The equivalent could be done by calling: |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
$output .= $self->local_textfield({name => 'sometext'}); |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
=cut |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
############################################################### |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
sub get_localised_name { |
746
|
0
|
|
|
0
|
1
|
|
my ($self, $name) = @_; |
747
|
|
|
|
|
|
|
|
748
|
0
|
|
|
|
|
|
my $localised_name = $self->get_id . $self->SEP . $name; |
749
|
0
|
|
|
|
|
|
return $localised_name; |
750
|
|
|
|
|
|
|
} |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
############################################################### |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
=head2 local_textfield |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
Generate a localised textfield |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
Example: |
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
$output .= $self->local_textfield({name => 'sometext'}); |
761
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
=cut |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
############################################################### |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
sub local_textfield { |
767
|
0
|
|
|
0
|
1
|
|
my ($self, $args) = @_; |
768
|
0
|
|
|
|
|
|
my $cgi = new CGI; |
769
|
0
|
|
|
|
|
|
$args->{name} = $self->get_localised_name($args->{name}); |
770
|
|
|
|
|
|
|
|
771
|
0
|
|
|
|
|
|
return $cgi->textfield($args); |
772
|
|
|
|
|
|
|
} |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
############################################################### |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
sub local_textarea { |
777
|
0
|
|
|
0
|
0
|
|
my ($self, $args) = @_; |
778
|
0
|
|
|
|
|
|
my $cgi = new CGI; |
779
|
0
|
|
|
|
|
|
$args->{name} = $self->get_localised_name($args->{name}); |
780
|
|
|
|
|
|
|
|
781
|
0
|
|
|
|
|
|
return $cgi->textarea($args); |
782
|
|
|
|
|
|
|
} |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
############################################################### |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
sub local_popup_menu { |
787
|
0
|
|
|
0
|
0
|
|
my ($self, $args) = @_; |
788
|
0
|
|
|
|
|
|
my $cgi = new CGI; |
789
|
0
|
|
|
|
|
|
$args->{name} = $self->get_localised_name($args->{name}); |
790
|
|
|
|
|
|
|
|
791
|
0
|
|
|
|
|
|
return $cgi->popup_menu($args); |
792
|
|
|
|
|
|
|
} |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
############################################################### |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
sub local_radio_group { |
797
|
0
|
|
|
0
|
0
|
|
my ($self, $args) = @_; |
798
|
0
|
|
|
|
|
|
my $cgi = new CGI; |
799
|
0
|
|
|
|
|
|
$args->{name} = $self->get_localised_name($args->{name}); |
800
|
|
|
|
|
|
|
|
801
|
0
|
|
|
|
|
|
return $cgi->radio_group($args); |
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
############################################################### |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
# Define the separator used when passing panel ids etc |
807
|
|
|
|
|
|
|
# and a version which can be used in regexps |
808
|
|
|
|
|
|
|
|
809
|
0
|
|
|
0
|
0
|
|
sub SEP { ':.:' } |
810
|
0
|
|
|
0
|
0
|
|
sub SEPRE { qr{:\.:} } |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
############################################################### |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
=head2 MAIN PANEL METHODS |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
These methods provide extra functionality useful for the main |
817
|
|
|
|
|
|
|
panel of an application. Apache::Session is used to handle session |
818
|
|
|
|
|
|
|
information. An application built using the CGI::Panel framework should |
819
|
|
|
|
|
|
|
typically have one main panel and a hierarchy of other panels, all of |
820
|
|
|
|
|
|
|
which inherit from CGI::Panel. |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
=head2 obtain |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
Obtains the master panel object |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
This will either restore the current master panel session |
827
|
|
|
|
|
|
|
or create a new one |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
Use: |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
my $shop = obtain Shop; |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
=cut |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
############################################################### |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
sub obtain |
838
|
|
|
|
|
|
|
{ |
839
|
0
|
|
|
0
|
1
|
|
my ($class) = @_; |
840
|
|
|
|
|
|
|
|
841
|
0
|
|
|
|
|
|
my $messages = $class->interpret_messages(); |
842
|
0
|
|
0
|
|
|
|
my $session_id = $messages->{session_id} || undef; |
843
|
|
|
|
|
|
|
|
844
|
0
|
|
|
|
|
|
my %session = $class->get_or_create_apache_session($session_id); |
845
|
|
|
|
|
|
|
|
846
|
0
|
|
|
|
|
|
my $panel; |
847
|
|
|
|
|
|
|
|
848
|
0
|
0
|
|
|
|
|
if ($session{mainpanel}) { |
849
|
0
|
|
|
|
|
|
$panel = $session{mainpanel}; |
850
|
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
|
else { |
852
|
0
|
|
|
|
|
|
$panel = new $class; |
853
|
|
|
|
|
|
|
} |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
# Store the session id in the panel object |
856
|
0
|
|
|
|
|
|
$panel->{session_id} = $session{_session_id}; |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
## Store the panel information in the session file |
859
|
|
|
|
|
|
|
#$panel->save; |
860
|
|
|
|
|
|
|
|
861
|
0
|
|
|
|
|
|
return $panel; |
862
|
|
|
|
|
|
|
} |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
############################################################### |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
sub tie_apache_session { |
867
|
0
|
|
|
0
|
0
|
|
my ($self, $session_id) = @_; |
868
|
|
|
|
|
|
|
|
869
|
0
|
|
|
|
|
|
my %session; |
870
|
0
|
|
|
|
|
|
tie %session, 'Apache::Session::File', $session_id, { |
871
|
|
|
|
|
|
|
Directory => $self->session_directory, |
872
|
|
|
|
|
|
|
LockDirectory => $self->lock_directory |
873
|
|
|
|
|
|
|
}; |
874
|
|
|
|
|
|
|
|
875
|
0
|
|
|
|
|
|
return %session; |
876
|
|
|
|
|
|
|
} |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
sub get_or_create_apache_session { |
879
|
0
|
|
|
0
|
0
|
|
my ($self, $session_id) = @_; |
880
|
|
|
|
|
|
|
|
881
|
0
|
|
|
|
|
|
my %session; |
882
|
0
|
|
|
|
|
|
eval { |
883
|
0
|
|
|
|
|
|
%session = $self->tie_apache_session($session_id); |
884
|
0
|
0
|
|
|
|
|
die "Session has expired" if $session{state} eq 'EXPIRED'; |
885
|
|
|
|
|
|
|
}; |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
# If the session doesn't exist or has expired, create a new one |
888
|
0
|
|
|
|
|
|
my $eval_result = $@; |
889
|
0
|
0
|
|
|
|
|
if ($eval_result =~ /(expired|does not exist)/) { |
|
|
0
|
|
|
|
|
|
890
|
0
|
|
|
|
|
|
%session = $self->tie_apache_session(undef); |
891
|
|
|
|
|
|
|
} |
892
|
|
|
|
|
|
|
elsif ($eval_result) { |
893
|
0
|
|
|
|
|
|
die "Unexpected problem in tie_apache_session: $eval_result"; |
894
|
|
|
|
|
|
|
} |
895
|
|
|
|
|
|
|
|
896
|
0
|
|
|
|
|
|
return %session; |
897
|
|
|
|
|
|
|
} |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
sub end_session { |
900
|
0
|
|
|
0
|
0
|
|
my ($self) = @_; |
901
|
|
|
|
|
|
|
|
902
|
0
|
0
|
|
|
|
|
my $session_id = $self->get_session_id |
903
|
|
|
|
|
|
|
or die "No session id"; |
904
|
0
|
|
|
|
|
|
my %session = $self->tie_apache_session($session_id); |
905
|
0
|
|
|
|
|
|
$session{state} = 'EXPIRED'; |
906
|
|
|
|
|
|
|
} |
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
############################################################### |
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
=head2 cycle |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
Performs a complete cycle of the application |
913
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
Takes all the actions that are required for a complete cycle |
915
|
|
|
|
|
|
|
of the application, including processing events and form data |
916
|
|
|
|
|
|
|
and displaying the updated screen. Also manages persistence |
917
|
|
|
|
|
|
|
for the panel hierarchy. |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
Use: |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
$shop->cycle(); |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
=cut |
924
|
|
|
|
|
|
|
|
925
|
|
|
|
|
|
|
############################################################### |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
sub cycle |
928
|
|
|
|
|
|
|
{ |
929
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
930
|
|
|
|
|
|
|
|
931
|
0
|
|
|
|
|
|
my $messages = $self->interpret_messages(); |
932
|
|
|
|
|
|
|
|
933
|
0
|
0
|
|
|
|
|
if ($messages->{event}) |
934
|
|
|
|
|
|
|
{ |
935
|
0
|
|
|
|
|
|
$self->handle_event($messages->{event}); |
936
|
|
|
|
|
|
|
} |
937
|
|
|
|
|
|
|
|
938
|
0
|
0
|
|
|
|
|
if ($messages->{n}) |
939
|
|
|
|
|
|
|
{ |
940
|
0
|
|
|
|
|
|
$self->handle_link_event($messages->{n}); |
941
|
|
|
|
|
|
|
} |
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
## $self->update(); # Probably don't need this as this |
944
|
|
|
|
|
|
|
# will always be handled as an event |
945
|
|
|
|
|
|
|
|
946
|
0
|
|
0
|
|
|
|
my $screen_name = $self->{screenname} || 'main'; |
947
|
0
|
|
|
|
|
|
my $screen_method = "screen_$screen_name"; |
948
|
0
|
|
|
|
|
|
$self->$screen_method(); |
949
|
|
|
|
|
|
|
|
950
|
0
|
|
|
|
|
|
$self->save(); |
951
|
|
|
|
|
|
|
|
952
|
0
|
|
|
|
|
|
return 1; |
953
|
|
|
|
|
|
|
} |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
############################################################### |
956
|
|
|
|
|
|
|
|
957
|
|
|
|
|
|
|
=head2 save |
958
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
Saves an object to persistent storage indexed by session id. You don't |
960
|
|
|
|
|
|
|
normally need to explicitly call this in your application, as it's called |
961
|
|
|
|
|
|
|
during the 'cycle' method. |
962
|
|
|
|
|
|
|
|
963
|
|
|
|
|
|
|
Use: |
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
$self->save; |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
=cut |
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
############################################################### |
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
sub save |
972
|
|
|
|
|
|
|
{ |
973
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
974
|
|
|
|
|
|
|
|
975
|
0
|
|
|
|
|
|
my $session_id = $self->{session_id}; |
976
|
|
|
|
|
|
|
|
977
|
0
|
0
|
|
|
|
|
die "ERROR: No session id for save - this shouldn't be possible!" |
978
|
|
|
|
|
|
|
unless $session_id; |
979
|
|
|
|
|
|
|
|
980
|
0
|
|
|
|
|
|
my %session; |
981
|
|
|
|
|
|
|
|
982
|
0
|
|
|
|
|
|
tie %session, 'Apache::Session::File', $session_id, { |
983
|
|
|
|
|
|
|
Directory => $self->session_directory, |
984
|
|
|
|
|
|
|
LockDirectory => $self->lock_directory |
985
|
|
|
|
|
|
|
}; |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
# Store our current state in the tied session hash (ie in persistent storage) |
988
|
0
|
|
|
|
|
|
$session{mainpanel} = $self; |
989
|
|
|
|
|
|
|
|
990
|
|
|
|
|
|
|
# Could we have some sort of check here to ensure that the session is |
991
|
|
|
|
|
|
|
# saved correctly. So if there is a problem (like trying to save |
992
|
|
|
|
|
|
|
# Net::FTP objects or Tangram storage objects where usually nothing |
993
|
|
|
|
|
|
|
# is stored) we detect this and report the problem. |
994
|
|
|
|
|
|
|
|
995
|
0
|
|
|
|
|
|
return 1; |
996
|
|
|
|
|
|
|
} |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
############################################################### |
999
|
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
|
=head2 get_panel_by_id |
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
Look up the panel in our list and return it. Note that this is |
1003
|
|
|
|
|
|
|
different to the 'panel' routine in CGI::Panel, which gets a |
1004
|
|
|
|
|
|
|
sub-panel of the current panel by name. All the panels |
1005
|
|
|
|
|
|
|
in an application will be registered with the main panel |
1006
|
|
|
|
|
|
|
which stores them in a special hash with an automatically |
1007
|
|
|
|
|
|
|
generated key. This routine gets any panel in the application |
1008
|
|
|
|
|
|
|
based on the key supplied. |
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
Use: |
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
my $panel_id = $main_panel->get_panel_by_id(3); |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
=cut |
1015
|
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
############################################################### |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
sub get_panel_by_id |
1019
|
|
|
|
|
|
|
{ |
1020
|
0
|
|
|
0
|
1
|
|
my ($self, $id) = @_; |
1021
|
|
|
|
|
|
|
|
1022
|
|
|
|
|
|
|
# WE SHOULD PROBABLY START USING A HASH HERE |
1023
|
|
|
|
|
|
|
# IN CASE PANELS ARE REMOVED... |
1024
|
0
|
|
|
|
|
|
my $panel = $self->{panel_list}->[$id]; |
1025
|
0
|
|
|
|
|
|
die "ERROR: Panel ($id) not found:" |
1026
|
0
|
0
|
|
|
|
|
. join ("\n", map { "$_ => " . ref ($self->{panel_list}->[$_]) } (0..10)) |
1027
|
|
|
|
|
|
|
unless $panel; |
1028
|
|
|
|
|
|
|
|
1029
|
0
|
|
|
|
|
|
return $panel; |
1030
|
|
|
|
|
|
|
} |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
############################################################### |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
=head1 OTHER METHODS |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
The following methods are used behind the scenes, usually from |
1037
|
|
|
|
|
|
|
the 'cycle' method above. They will generally be sufficient as |
1038
|
|
|
|
|
|
|
they are but can be overridden if necessary for greater |
1039
|
|
|
|
|
|
|
flexibility. |
1040
|
|
|
|
|
|
|
|
1041
|
|
|
|
|
|
|
=cut |
1042
|
|
|
|
|
|
|
|
1043
|
|
|
|
|
|
|
############################################################### |
1044
|
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
|
=head2 register_panel |
1046
|
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
Accept a panel object and 'register' it - ie store a reference to |
1048
|
|
|
|
|
|
|
it in a special list. Return the id (hash key) to the caller. |
1049
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
Use: |
1051
|
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
|
my $id = $main_panel->register($panel); |
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
=cut |
1055
|
|
|
|
|
|
|
|
1056
|
|
|
|
|
|
|
############################################################### |
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
sub register_panel |
1059
|
|
|
|
|
|
|
{ |
1060
|
0
|
|
|
0
|
1
|
|
my ($self, $panel) = @_; |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
# Create the panel list if it doesn't already exist |
1063
|
0
|
0
|
|
|
|
|
$self->{panel_list} = [] unless $self->{panel_list}; |
1064
|
|
|
|
|
|
|
|
1065
|
0
|
|
|
|
|
|
my $list_size = scalar(@{$self->{panel_list}}); |
|
0
|
|
|
|
|
|
|
1066
|
0
|
|
|
|
|
|
push @{$self->{panel_list}}, $panel; |
|
0
|
|
|
|
|
|
|
1067
|
|
|
|
|
|
|
|
1068
|
0
|
|
|
|
|
|
return $list_size; |
1069
|
|
|
|
|
|
|
} |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
############################################################### |
1072
|
|
|
|
|
|
|
|
1073
|
|
|
|
|
|
|
=head2 screen_main |
1074
|
|
|
|
|
|
|
|
1075
|
|
|
|
|
|
|
Display main screen for the master panel. This is called |
1076
|
|
|
|
|
|
|
automatically by the 'cycle' routine. Other screen methods |
1077
|
|
|
|
|
|
|
can be defined if necessary, however judicious use of panels |
1078
|
|
|
|
|
|
|
should avoid the need for this. |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
=cut |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
############################################################### |
1083
|
|
|
|
|
|
|
|
1084
|
|
|
|
|
|
|
sub screen_main |
1085
|
|
|
|
|
|
|
{ |
1086
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
1087
|
|
|
|
|
|
|
|
1088
|
0
|
|
|
|
|
|
my $cgi = new CGI; |
1089
|
|
|
|
|
|
|
|
1090
|
0
|
|
|
|
|
|
print |
1091
|
|
|
|
|
|
|
$cgi->header() . |
1092
|
|
|
|
|
|
|
$cgi->start_form() . |
1093
|
|
|
|
|
|
|
$cgi->hidden({name => 'session_id', |
1094
|
|
|
|
|
|
|
default => $self->get_session_id(), |
1095
|
|
|
|
|
|
|
override => 1}) . |
1096
|
|
|
|
|
|
|
$self->display() . |
1097
|
|
|
|
|
|
|
$cgi->end_form(); |
1098
|
|
|
|
|
|
|
} |
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
############################################################### |
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
=head2 handle_event |
1103
|
|
|
|
|
|
|
|
1104
|
|
|
|
|
|
|
Handle a button event by passing the event information to the |
1105
|
|
|
|
|
|
|
appropriate event routine of the correct panel. |
1106
|
|
|
|
|
|
|
Currently this is always the panel that generates the event. |
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
=cut |
1109
|
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
|
############################################################### |
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
sub handle_event |
1113
|
|
|
|
|
|
|
{ |
1114
|
0
|
|
|
0
|
1
|
|
my ($self, $event_details) = @_; |
1115
|
|
|
|
|
|
|
|
1116
|
0
|
|
|
|
|
|
my ($name, $routine_name, $panel_id) = split($self->SEPRE, $event_details); |
1117
|
0
|
0
|
0
|
|
|
|
die "ERROR: Unable to obtain name or routine name" |
1118
|
|
|
|
|
|
|
unless $name && $routine_name; |
1119
|
|
|
|
|
|
|
|
1120
|
0
|
|
|
|
|
|
my $real_routine_name = "_event_" . $routine_name; |
1121
|
|
|
|
|
|
|
|
1122
|
0
|
|
|
|
|
|
my $target_panel = $self->get_panel_by_id($panel_id); |
1123
|
0
|
|
|
|
|
|
$target_panel->$real_routine_name({name => $name}); |
1124
|
|
|
|
|
|
|
} |
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
############################################################### |
1127
|
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
=head2 handle_link_event |
1129
|
|
|
|
|
|
|
|
1130
|
|
|
|
|
|
|
Handle a link event by passing the event information to the |
1131
|
|
|
|
|
|
|
appropriate event routine of the correct panel. |
1132
|
|
|
|
|
|
|
Currently this is always the panel that generates the event. |
1133
|
|
|
|
|
|
|
|
1134
|
|
|
|
|
|
|
=cut |
1135
|
|
|
|
|
|
|
|
1136
|
|
|
|
|
|
|
############################################################### |
1137
|
|
|
|
|
|
|
|
1138
|
|
|
|
|
|
|
sub handle_link_event { |
1139
|
0
|
|
|
0
|
1
|
|
my ($self, $event_details) = @_; |
1140
|
|
|
|
|
|
|
|
1141
|
0
|
|
|
|
|
|
$self->handle_event($event_details); |
1142
|
|
|
|
|
|
|
} |
1143
|
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
|
############################################################### |
1145
|
|
|
|
|
|
|
|
1146
|
|
|
|
|
|
|
=head2 interpret_messages |
1147
|
|
|
|
|
|
|
|
1148
|
|
|
|
|
|
|
Read the request information using the CGI module and |
1149
|
|
|
|
|
|
|
present this data in a more structured way. In particular |
1150
|
|
|
|
|
|
|
this detects events and decodes the information associated |
1151
|
|
|
|
|
|
|
with them. |
1152
|
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
|
=cut |
1154
|
|
|
|
|
|
|
|
1155
|
|
|
|
|
|
|
############################################################### |
1156
|
|
|
|
|
|
|
|
1157
|
|
|
|
|
|
|
sub interpret_messages |
1158
|
|
|
|
|
|
|
{ |
1159
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
1160
|
|
|
|
|
|
|
|
1161
|
0
|
|
|
|
|
|
my $cgi = new CGI; |
1162
|
0
|
|
|
|
|
|
my $t_messages = { map { $_ => $cgi->param($_) } $cgi->param() }; |
|
0
|
|
|
|
|
|
|
1163
|
0
|
|
|
|
|
|
my $messages; |
1164
|
|
|
|
|
|
|
|
1165
|
|
|
|
|
|
|
# Need to untaint here |
1166
|
|
|
|
|
|
|
|
1167
|
0
|
|
|
|
|
|
foreach my $messagename(keys %$t_messages) |
1168
|
|
|
|
|
|
|
{ |
1169
|
|
|
|
|
|
|
# Untaint |
1170
|
0
|
|
|
|
|
|
$t_messages->{$messagename} =~ /^(.*)$/; |
1171
|
0
|
|
|
|
|
|
my $untainted_value = $1; |
1172
|
0
|
|
|
|
|
|
$messages->{$messagename} = $untainted_value; |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
# Look for events |
1175
|
0
|
0
|
|
|
|
|
if ($messagename =~ /^eventbutton\+(.*)$/s) |
1176
|
|
|
|
|
|
|
{ |
1177
|
0
|
|
|
|
|
|
my $buttondata = $1; |
1178
|
|
|
|
|
|
|
# my $buttonmessages; |
1179
|
|
|
|
|
|
|
# eval ('$buttonmessages = ' . decrypt($buttondata)); |
1180
|
|
|
|
|
|
|
# die "ERROR: eval failed ($@)" if $@; |
1181
|
|
|
|
|
|
|
# $messages->{event} = $buttonmessages; |
1182
|
0
|
|
|
|
|
|
$messages->{event} = $buttondata; |
1183
|
|
|
|
|
|
|
} |
1184
|
|
|
|
|
|
|
# Other parameters can be handled here... |
1185
|
|
|
|
|
|
|
} |
1186
|
|
|
|
|
|
|
|
1187
|
0
|
|
|
|
|
|
return $messages; |
1188
|
|
|
|
|
|
|
} |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
############################################################### |
1191
|
|
|
|
|
|
|
|
1192
|
|
|
|
|
|
|
=head2 session_directory |
1193
|
|
|
|
|
|
|
|
1194
|
|
|
|
|
|
|
This method returns the name of the directory that is used to |
1195
|
|
|
|
|
|
|
store the session files. It's currently set to '/tmp'. Override |
1196
|
|
|
|
|
|
|
this method to return a different directory if desired. |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
=cut |
1199
|
|
|
|
|
|
|
|
1200
|
|
|
|
|
|
|
############################################################### |
1201
|
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
|
sub session_directory { |
1203
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
1204
|
|
|
|
|
|
|
|
1205
|
|
|
|
|
|
|
# Get cached result if we have it |
1206
|
|
|
|
|
|
|
#return $class_session_directory |
1207
|
|
|
|
|
|
|
# if $class_session_directory}; |
1208
|
|
|
|
|
|
|
|
1209
|
0
|
|
|
|
|
|
my $session_directory = '/tmp'; |
1210
|
|
|
|
|
|
|
# $session_directory = '/tmp/sessions' |
1211
|
|
|
|
|
|
|
# if -d '/tmp/sessions'; |
1212
|
|
|
|
|
|
|
#$class_session_directory = $session_directory; |
1213
|
0
|
|
|
|
|
|
return $session_directory; |
1214
|
|
|
|
|
|
|
} |
1215
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
############################################################### |
1217
|
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
|
=head2 lock_directory |
1219
|
|
|
|
|
|
|
|
1220
|
|
|
|
|
|
|
This method returns the name of the directory that is used to |
1221
|
|
|
|
|
|
|
store the lock files. It's currently set to '/tmp'. Override |
1222
|
|
|
|
|
|
|
this method to return a different directory if desired. |
1223
|
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
|
=cut |
1225
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
############################################################### |
1227
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
sub lock_directory { |
1229
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
1230
|
|
|
|
|
|
|
|
1231
|
|
|
|
|
|
|
# Get cached result if we have it |
1232
|
|
|
|
|
|
|
#return $class_lock_directory |
1233
|
|
|
|
|
|
|
# if $class_lock_directory; |
1234
|
|
|
|
|
|
|
|
1235
|
0
|
|
|
|
|
|
my $lock_directory = '/tmp'; |
1236
|
|
|
|
|
|
|
# $lock_directory = '/var/lock' |
1237
|
|
|
|
|
|
|
# if -d '/var/lock'; |
1238
|
|
|
|
|
|
|
# $lock_directory = '/var/lock/sessions' |
1239
|
|
|
|
|
|
|
# if -d '/var/lock/sessions'; |
1240
|
|
|
|
|
|
|
# #$class_lock_directory = $lock_directory; |
1241
|
0
|
|
|
|
|
|
return $lock_directory; |
1242
|
|
|
|
|
|
|
} |
1243
|
|
|
|
|
|
|
|
1244
|
|
|
|
|
|
|
############################################################### |
1245
|
|
|
|
|
|
|
|
1246
|
|
|
|
|
|
|
1; #this line is important and will help the module return a true value |
1247
|
|
|
|
|
|
|
__END__ |