File Coverage

blib/lib/CGI/Panel.pm
Criterion Covered Total %
statement 23 225 10.2
branch 0 58 0.0
condition 0 19 0.0
subroutine 7 43 16.2
pod 26 36 72.2
total 56 381 14.7


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             '' . " } @{$self->{contents}})) . ' . ' . ' . ' .
101             join('', (map { "
$_
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__