| 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__ |