line
stmt
bran
cond
sub
pod
time
code
1
=head1 NAME
2
3
HTML::FormEngine - create,validate and control html/xhtml forms
4
5
=cut
6
7
######################################################################
8
9
package HTML::FormEngine;
10
require 5.004;
11
12
# Copyright (c) 2003-2004, Moritz Sinn. This module is free software;
13
# you can redistribute it and/or modify it under the terms of the
14
# GNU GENERAL PUBLIC LICENSE, see COPYING for more information.
15
16
1
1
20320
use strict;
1
2
1
34
17
1
1
5
use vars qw($VERSION);
1
1
1
56
18
$VERSION = '1.01';
19
20
######################################################################
21
22
=head1 DEPENDENCIES
23
24
=head2 Perl Version
25
26
5.004
27
28
=head2 Standard Modules
29
30
Carp
31
32
=head2 Nonstandard Modules
33
34
Clone 0.13
35
Hash::Merge 0.07
36
Locale::gettext 1.01
37
Date::Pcalc 1.2
38
Digest::MD5 2.24
39
HTML::Entities 1.27
40
41
=cut
42
43
######################################################################
44
45
1
1
624
use Clone qw(clone);
1
2687
1
61
46
1
1
739
use Hash::Merge qw(merge);
1
2485
1
63
47
1
1
8
use Carp;
1
2
1
41
48
1
1
476
use HTML::FormEngine::SkinClassic;
1
3
1
6354
49
50
######################################################################
51
52
=head1 SYNOPSIS
53
54
=head2 Example Code
55
56
#!/usr/bin/perl -w
57
58
use strict;
59
use CGI;
60
use HTML::FormEngine;
61
#use POSIX; # for setlocale
62
#setlocale(LC_MESSAGES, 'german'); # for german error messages
63
64
my $q = new CGI;
65
print $q->header;
66
67
my $Form = HTML::FormEngine->new(scalar $q->Vars);
68
my @form = (
69
{
70
templ => 'select',
71
NAME => 'Salutation',
72
OPTION => [[['mr.','mrs.']]],
73
},
74
{
75
templ => 'hidden_no_title',
76
NAME => 'test123',
77
VALUE => 'test',
78
},
79
{
80
SIZE => 10,
81
MAXLEN => 20,
82
PREFIX => [[' ', ' / ']],
83
NAME => 'name',
84
TITLE => 'For- / Surname ',
85
ERROR_IN => 'not_null'
86
},
87
{
88
MAXLEN => 30,
89
NAME => 'Email',
90
ERROR => ['not_null', ['rfc822'], ['match', 'matched net!']] # rfc822 defines the email address standard
91
},
92
{
93
templ => 'radio',
94
TITLE => 'Subscribe to newsletter?',
95
NAME => 'newsletter',
96
OPT_VAL => [[1, 2, 3]],
97
OPTION => [['Yes', 'No', 'Perhaps']],
98
VALUE => 1
99
},
100
{
101
templ => 'check',
102
OPTION => 'I agree to the terms of condition!',
103
NAME => "agree",
104
TITLE => '',
105
ERROR => sub{ return("you've to agree!") if(! shift); }
106
}
107
);
108
109
$Form->set_seperate(1);
110
$Form->conf(\@form);
111
$Form->make();
112
113
print $q->start_html('FormEngine example: Registration');
114
if($Form->ok){
115
$Form->clear();
116
print "You've successfully subscribed! ";
117
}
118
print $Form->get,
119
$q->end_html;
120
121
=head2 Example Output
122
123
This output is produced by FormEngine when using the example code and
124
no data was submitted:
125
126
127
303
304
305
306
=head1 DESCRIPTION
307
308
FormEngine.pm is a Perl 5 object class which provides an api for
309
managing html/xhtml forms. FormEngine has its own, very flexible
310
template system for defining form skins. A default skin and a more
311
flexible one is provided. This should be sufficent in most cases, but
312
extending the skins or making your own isn't difficult (please send
313
them to me!).
314
315
FormEngine also provides a set of functions for checking the form
316
input, it is very easy to define your own check methods or to adapt
317
the given.
318
319
I is used for internationalization (e.g. error messages). So
320
use C if you want to have german
321
error messages, butten lables and so on (there isn't support for any
322
other language yet, but it shouldn't be difficult to translate the .po
323
file, don't hesitate!).
324
325
Another usefull feature is the C method which forces the user
326
to read through his input once again before submitting it.
327
328
FormEngine is designed to make extension writing an easy task!
329
330
=head1 OVERVIEW
331
332
Start with calling the C method, it will return an FormEngine
333
object. As argument you should pass a reference to a hash of input
334
values (calling C is also possible, environments like
335
mod_perl or CGI.pm offer already a hash of input values, see
336
C for more). Now define an array which contains the form
337
configuration and pass a reference to C. Then call C, this
338
will generate the html code. Next you can use C to check if the
339
form was submitted and all input values are correct. If this is the
340
case, you can e.g. display a success message and call
341
C for getting the value of a certain field and
342
e.g. write it in a database. Else you should call C (which will
343
return the html form code) or C which will directly print the
344
form.
345
346
If you want the form to be always displayed, you can use C to
347
empty it (resp. display the defaults) when the transmission was
348
successfull.
349
350
=head1 USING FORMENGINE
351
352
The easiest way to define your form is to create an array of hash
353
references:
354
355
my @form = (
356
{
357
templ => 'select',
358
NAME => 'Salutation',
359
OPTION => [[['mr.','mrs.']]],
360
},
361
{
362
templ => 'hidden_no_title',
363
NAME => 'test123',
364
VALUE => 'test',
365
},
366
{
367
SIZE => 10,
368
MAXLEN => 20,
369
PREFIX => [[' ', ' / ']],
370
NAME => 'name',
371
TITLE => 'For- / Surname ',
372
ERROR_IN => 'not_null'
373
},
374
{
375
MAXLEN => 30,
376
NAME => 'Email',
377
ERROR => ['not_null', ['rfc822'], ['match', 'matched net!']] # rfc822 defines the email address standard
378
},
379
{
380
templ => 'radio',
381
TITLE => 'Subscribe to newsletter?',
382
NAME => 'newsletter',
383
OPT_VAL => [[1, 2, 3]],
384
OPTION => [['Yes', 'No', 'Perhaps']],
385
VALUE => 1
386
},
387
{
388
templ => 'check',
389
OPTION => 'I agree to the terms of condition!',
390
NAME => "agree",
391
TITLE => '',
392
ERROR => sub{ return("you've to agree!") if(! shift); }
393
}
394
);
395
396
This was taken out of the example above. The I key defines the
397
field type (resp. template), the capital written keys are explained
398
below. If I is not defined, it is expected to be C.
399
400
Then pass a reference to that array to the C method like this:
401
402
$Form->conf(\@form);
403
404
Another possibility is to define a hash of hash references and pass a
405
reference on that to C. This is seldom needed, but has the
406
advantage that you can define low level variables:
407
408
my %form = (
409
METHOD => 'get',
410
FORMNAME => 'myform',
411
SUBMIT => 'Yea! I want that!',
412
'sub' => [
413
# Here you place your form definition (see above)
414
]
415
);
416
417
$Form->conf(\%form);
418
419
The meaning of the keys is explained below. You can call
420
C for setting low level (main) variables as well, the
421
only difference is that the variables set through L
422
HASHREF )> are persistend, that means even if you call the L
423
FORMCONF )> method again they're still set if not overwritten.
424
425
=head2 The Default Skin (FormEngine)
426
427
If you want to use the same fieldname several times (e.g. for a group
428
of checkboxes or for two textfields like name and forename), you have
429
to call C and pass 1 (for true). See C for
430
more.
431
432
The following templates are known by the default skin:
433
434
=over
435
436
=item
437
438
B - text input field(s), one row
439
440
=item
441
442
B
443
444
=item
445
446
B - check box list (one can be selected)
447
448
=item
449
450
B - pull down menu or a box with options (one or several can
451
be selected)
452
453
=item
454
455
B - check box list (several can be selected)
456
457
=item
458
459
B - invisible field(s), can be used for passing data
460
461
=item
462
463
B - displays a standard, submit or a reset button
464
465
=item
466
467
B - this template simply prints out the submitted value but
468
also saves it because it contains a hidden field
469
470
=back
471
472
The following templates are also known by the default skin but perhaps
473
a bit more difficult to understand and not so often used:
474
475
=over
476
477
=item
478
479
B - like select but lets you subdevide the options in
480
groups (see examples/namechooser.cgi)
481
482
=item
483
484
B - lets you mix optgroup,optgroup_flexible and
485
option (see examples/namechooser.cgi)
486
487
=item
488
489
B - has to be placed in C,
490
C or similar (see examples/namechooser.cgi)
491
492
=item
493
494
B - lets you nest option groups, cannot exist on
495
the first level (see examples/namechooser.cgi)
496
497
=item
498
499
B - has to be placed in C,
500
C or similar (see examples/namechooser.cgi)
501
502
=item
503
504
B - can be used for grouping fields (see
505
examples/feedback_fieldset.cgi)
506
507
=back
508
509
These fields are normally only used automatically for generating the
510
confirmation form but could be that they're also for some individual
511
usage:
512
513
=over
514
515
=item
516
517
B - like C but for printing out a list of
518
submitted options
519
520
=item
521
522
B - just used to print a list of other templates
523
524
=back
525
526
If you want to nest templates resp. place a template in another
527
template you have to call it with a leading '_' (underscore). So use
528
I<_text> instead of I and so on.
529
530
Add I<_notitle> to the templates name if you don't want to have a
531
title, add I<_noerror> if you don't want to check for errors, add
532
I<_notitle_noerror> if you don't want both and simply add a I<2> if
533
you want the error messages to stand under the field and not next to
534
it. Read and run the I for more information.
535
536
B: All information given here about templates and variables is
537
only valid for the default skin and for SkinComplex. Other skins
538
should bring their own documentation.
539
540
=head2 Variables
541
542
Note that if you don't use the default skin, things might be
543
diffrent. But mostly only the layout changes. A skin which doesn't
544
fit to the following conventiones should have its own documentation.
545
546
These Variables are B available:
547
548
=over
549
550
=item
551
552
B - the form fields name (this must be passed to L
553
FIELDNAME )> for getting the complying value)
554
555
=item
556
557
B - the displayed title of the field, by default the value of
558
NAME
559
560
=item
561
562
B - the default (or initial) value of the field
563
564
=item
565
566
B - accepts name of an FormEngine check routine (see Config.pm
567
and Checks.pm), an anonymous function or an reference to a named
568
method. If an array reference is passed, a list of the above mentioned
569
values is expected. FormEngine will then call these routines one after
570
another until an error message is returned or the end of the list is
571
reached. If you want to alter the default error messages or you want
572
to pass arguments to it, you can do so by passing arrays like
573
I<[checkmethod, "error message", arg1, arg2]>, see C
574
for an example.
575
576
=back
577
578
These variables are available for the B only:
579
580
=over
581
582
=item
583
584
B - the physical length of the field (in characters) [default:
585
20]
586
587
=item
588
589
B - max. count of characters that can be put into the field
590
[default: no limit]
591
592
=item
593
594
B - if set to I for each character a I<*> is printed
595
(instead of the character) [default: I]
596
597
=back
598
599
These variables are available for B (C,
600
C, C and all similar ones) only:
601
602
=over
603
604
=item
605
606
B - accepts an reference to an array with options
607
608
=item
609
610
B - accepts an reference to an array with values for the
611
options (by default the value of OPTION is used)
612
613
=back
614
615
These variables are available for the B and all
616
similar ones:
617
618
=over
619
620
=item
621
622
B - defines the titles of the option groups
623
624
=back
625
626
These variables are available for the B
627
628
=over
629
630
=item
631
632
B - the width of the text input area [default: 27]
633
634
=item
635
636
B - the height of the text input area [default: 10]
637
638
=back
639
640
These variables are available for the B only:
641
642
=over
643
644
=item
645
646
B - can be 'button', 'submit' or 'reset' [default: 'button']
647
648
=back
649
650
These variables are so called B, they can be set by
651
using the hash notation (see L) or by calling
652
L:
653
654
=over
655
656
=item
657
658
B - the url of the page to which the form data should be
659
submitted [default: $ENV{REQUEST_URI}, that means: the script calls
660
itself]. Normally it doesn't make sense to change this value, but when
661
you use mod_perl, you should set it to I<$r->uri>.
662
663
=item
664
665
B - can be 'post' (transmit the data in HTTP header) or 'get'
666
(transmit the data by appeding it to the url) [default: post].
667
668
=item
669
670
B - the text that should be displayed on the submit button
671
[default: Ok]
672
673
=item
674
675
B - the string by which this form should be identified
676
[default: FormEngine]. You must change this if you have more than one
677
FormEngine-made form on a page. Else FormEngine won't be able to
678
distinguish which form was submitted.
679
680
=back
681
682
B: only NAME must be set, all other variables are optional.
683
684
Please also run the example scripts and read their code (they're very
685
short), it'll help you a lot understanding how to use FormEngine.
686
687
To really understand the skin system, how it works and what
688
possibilites there are you'll have to read the documentation of and
689
the code in the following files: Skin.pm, SkinComplex.pm,
690
SkinClassic.pm, SkinClassicConfirm.pm. These files are related to each
691
other in exactly this order, there's also SkinClassicConfirm.pm which
692
inherits everythings from SkinComplex but besides that it looks the
693
same like SkinClassicConfirm.pm.
694
695
B
696
above, you have to read the template definitions in the skin packages
697
to know more!>
698
699
=head2 Methods For Creating Forms
700
701
=head3 new ([ HASHREF ])
702
703
This method is the constructor. It returns an FormEngine object. You
704
should pass the form input in a hash reference to it, but you can use
705
L as well.
706
707
=cut
708
709
######################################################################
710
711
sub new {
712
1
1
1
13
my $class = shift;
713
1
33
10
my $self = bless( {}, ref($class) || $class);
714
1
6
$self->_initialize(shift);
715
0
0
$self->_initialize_child(@_);
716
0
0
return $self;
717
}
718
719
######################################################################
720
721
=head3 set_input ( HASHREF )
722
723
You have to pass a reference to a hash with input values. You can
724
pass this hash reference to the constructor (C) as well, then you
725
don't need this function. If you use mod_perl you can get this
726
reference by calling 'scalar $m->request_args'. If you use CGI.pm you
727
get it by calling 'scalar $q->Vars'.
728
729
=cut
730
731
######################################################################
732
733
sub set_input {
734
1
1
1
2
my ($self, $input) = @_;
735
736
1
50
4
if(ref($input) eq 'HASH') {
737
0
0
foreach (keys(%{$input})) {
0
0
738
#the following is needed if the input was forwarded from CGI.pm (arrays are represented by strings, the fields are seperated by \0)
739
0
0
0
0
if(defined($input->{$_}) && !ref($input->{$_}) && $input->{$_} =~ m/\0/o) {
0
740
0
0
$self->{input}->{$_} = [];
741
0
0
@{$self->{input}->{$_}} = split("\0", $input->{$_});
0
0
742
} else {
743
0
0
$self->{input}->{$_} = $input->{$_};
744
}
745
}
746
0
0
return 1
747
}
748
749
1
3
return 0
750
}
751
752
######################################################################
753
754
=head3 conf ( FORMCONF )
755
756
You have to pass the configuration of your form as array or hash
757
reference (see L).
758
759
=cut
760
761
######################################################################
762
763
sub conf {
764
0
0
1
0
my ($self, $conf) = @_;
765
766
0
0
0
$self->{conf} = $self->_check_conf($conf) or return 0;
767
768
0
0
local $_;
769
0
0
foreach $_ (keys(%{$self->{conf_main}})) {
0
0
770
0
0
0
$self->{conf}->{$_} = $self->{conf_main}->{$_} unless(defined($self->{conf}->{$_}));
771
}
772
0
0
return 1;
773
}
774
775
######################################################################
776
777
=head3 set_seperate ( BOOLEAN )
778
779
You've to pass true in case you want to use the same field name in
780
diffrent template calls. Its turned off by default because you won't
781
be able to set field values with java-script once it is enabled (which
782
doesn't matter in most cases).
783
784
=cut
785
786
######################################################################
787
788
sub set_seperate {
789
0
0
1
0
my($self,$sep) = @_;
790
0
0
0
0
$self->{seperate} = $sep and return 1 if(defined($sep));
791
0
0
return 0;
792
}
793
794
######################################################################
795
796
=head3 set_main_vars ( HASHREF )
797
798
You can use this method for setting the values of the I template
799
variables (e.g. I). Another possibility to do that is using
800
the hash notation when configuring the form (see L).
801
The diffrence is that the object saves the settings made through this
802
method so that they're automatically reset when calling the L
803
FORMCONF )> method again. If you set the variables directly throught
804
the hash notation they're not persistent.
805
806
This method doesn't overwrite all settings which where probably
807
already made before, it only overwrites the variables which are
808
defined in the given HASH! So you can call this method several times
809
to complete your configuration or overwrite certain values.
810
811
To delete I variable settings use L.
812
813
=cut
814
815
######################################################################
816
817
sub set_main_vars {
818
# if the array notation is used for configuration, there is no
819
# other possibility to set the values of the main-template variables
820
# than using this function
821
0
0
1
0
my ($self,$varval) = @_;
822
0
0
0
0
if(defined($varval) && ref($varval) eq 'HASH') {
823
0
0
foreach $_ (keys(%{$varval})) {
0
0
824
0
0
$self->{conf_main}->{$_} = $varval->{$_};
825
0
0
$self->{conf}->{$_} = $varval->{$_};
826
}
827
}
828
}
829
830
######################################################################
831
832
=head3 del_main_vars ( ARRAY )
833
834
Use this method to unset so called I variables. They're not only
835
removed out of the form configuration but also out of the cache so
836
that you can get rid of settings that you once made with
837
L but which you don't want anymore, in fact
838
this is the real purpose of this method. Just pass the names of the
839
variables which should not be defined anymore.
840
841
=cut
842
843
######################################################################
844
845
sub del_main_vars {
846
0
0
1
0
my ($self, @del) = @_;
847
0
0
local $_;
848
0
0
foreach $_ (@del) {
849
0
0
delete $self->{conf_main}->{$_};
850
0
0
delete $self->{conf}->{$_};
851
}
852
}
853
854
######################################################################
855
856
=head3 clear ( )
857
858
If the form was submitted, this method simply calls L
859
VALUE )> and L. It sets both to false. If
860
make was already called, it calls it again, so that no user input is
861
shown and no error checking is done. Use it to reset the form.
862
863
=cut
864
865
######################################################################
866
867
sub clear {
868
0
0
1
0
my $self = shift;
869
0
0
0
if($self->is_submitted) {
870
0
0
$self->set_use_input(0);
871
0
0
$self->set_error_chk(0);
872
0
0
0
$self->make() if($self->{cont} ne '');
873
}
874
}
875
876
######################################################################
877
878
=head3 set_error_chk ( VALUE )
879
880
Sets whether the error handler should be called or not.
881
Default is true (1).
882
883
=cut
884
885
######################################################################
886
887
sub set_error_chk {
888
0
0
1
0
my $self = shift;
889
0
0
0
$self->{check_error} = (shift||0);
890
}
891
892
######################################################################
893
894
=head3 set_use_input ( VALUE )
895
896
Sets whether the given input should be displayed in the form fields or
897
not. Default is true (1).
898
899
=cut
900
901
######################################################################
902
903
sub set_use_input {
904
0
0
1
0
my $self = shift;
905
0
0
0
$self->{use_input} = (shift||0);
906
}
907
908
######################################################################
909
910
=head3 make ( )
911
912
Creates the html/xhtml output, but doesn't return it (see L and
913
L). Every method call which influences this output must be
914
called before calling make!
915
916
=cut
917
918
######################################################################
919
920
sub make {
921
# this initialises the complex parsing process
922
# all configuration must be done before calling make
923
0
0
1
0
my $self = shift;
924
0
0
foreach $_ (@{$self->{call_before_make}}) {
0
0
925
0
0
0
&$_($self) if(ref($_) eq 'CODE');
926
}
927
0
0
my $pupo_defaults = $self->_push_varstack($self->{skin_obj}->get_default('default'), 'varstack_defaults');
928
0
0
$self->{cont} = $self->_parse('<&main&>', 1);
929
0
0
$self->_pop_varstack($pupo_defaults, 'varstack_defaults');
930
0
0
0
return 1 if($self->{cont});
931
0
0
return 0;
932
}
933
934
######################################################################
935
936
=head3 print ( )
937
938
Sends the html/xhtml output directly to STDOUT. L must be called
939
first!
940
941
=cut
942
943
######################################################################
944
945
sub print {
946
0
0
1
0
my $self = shift;
947
0
0
print $self->get(), "\n";
948
0
0
return 1;
949
}
950
951
######################################################################
952
953
=head3 get ( )
954
955
Returns the html/xhtml form code in a string. L must be called
956
first!
957
958
=cut
959
960
######################################################################
961
962
sub get {
963
0
0
1
0
my $self = shift;
964
0
0
0
$self->make if($self->{call_make});
965
0
0
$self->{call_make} = 0;
966
0
0
return $self->{cont};
967
}
968
969
######################################################################
970
971
=head3 ok ( )
972
973
Returns true (1) if the form was submitted and no errors were found!
974
Else it returns false (0).
975
976
This method simply calls L and L but
977
also checks whether a confirmation was canceled
978
(L). So normally you'll use this method instead
979
of calling all 3 functions, especially if you deal with the
980
confirmation feature of FormEngine (see L).
981
982
L must be called before calling this method!
983
984
=cut
985
986
######################################################################
987
988
sub ok {
989
0
0
1
0
my $self = shift;
990
0
0
0
return $self->is_submitted && (! $self->get_error_count) && (! $self->confirmation_canceled);
991
}
992
993
######################################################################
994
995
=head3 get_error_count ( )
996
997
Returns the count of errors which where found by the error handler.
998
L must be called first!
999
1000
=cut
1001
1002
######################################################################
1003
1004
sub get_error_count {
1005
0
0
1
0
my $self = shift;
1006
0
0
return $self->{errcount};
1007
}
1008
1009
######################################################################
1010
1011
=head3 is_submitted ( )
1012
1013
Returns true (1) if the form was submitted, false (0) if not.
1014
1015
=cut
1016
1017
######################################################################
1018
1019
sub is_submitted {
1020
0
0
1
0
my $self = shift;
1021
0
0
0
return $self->{input}->{$self->get_formname()} ? 1 : 0;
1022
}
1023
1024
######################################################################
1025
1026
=head3 errors ( )
1027
1028
Returns I if the form was submitted and errors where found.
1029
1030
=cut
1031
1032
######################################################################
1033
1034
sub errors {
1035
0
0
1
0
my $self = shift;
1036
0
0
0
return $self->is_submitted && $self->get_error_count;
1037
}
1038
1039
######################################################################
1040
1041
=head3 confirmation_canceled ( )
1042
1043
Returns I if the user pressed I when he was asked to
1044
confirm the given input.
1045
1046
=cut
1047
1048
######################################################################
1049
1050
sub confirmation_canceled {
1051
0
0
1
0
my $self = shift;
1052
0
0
0
return defined($self->{input}->{($self->{conf}->{CONFIRM_CANCEL} || $self->{skin_obj}->get_default('main','CONFIRM_CANCEL'))});
1053
}
1054
1055
######################################################################
1056
1057
=head3 get_input ( FIELDNAME )
1058
1059
Returns the input value of the corresponding field. If it has only
1060
one value a scalar, if it has several values an array is returned. If
1061
C was called with 1 (true) it packs the values which
1062
belong together into subarrays.
1063
1064
=cut
1065
1066
######################################################################
1067
1068
#this method simply calls _get_input and turns arrays into scalars if they have only 1 element (that is more user friendly)
1069
#for internal usage _get_input is better because it has a more integrative return value type
1070
sub get_input {
1071
0
0
1
0
my($self,$fname) = @_;
1072
0
0
my $res = $self->_get_input($fname);
1073
0
0
for(0..$self->{seperate}) {
1074
0
0
0
0
$res = $res->[0] if(ref($res) eq 'ARRAY' and @$res == 1);
1075
}
1076
0
0
return $res;
1077
}
1078
1079
#an alias for get_input (for being at least a bit backward compatible)
1080
sub get_input_value {
1081
0
0
0
0
my $self = shift;
1082
0
0
return $self->get_input(shift);
1083
}
1084
1085
######################################################################
1086
1087
=head3 confirm ( [CONFIRMMSG] )
1088
1089
Calling this method will print the users input data and ask him to
1090
click 'Ok' or 'Cancel'. 'Ok' will submit the data once again and then
1091
C will return true (1). 'Cancel' will display the form,
1092
so that the user can change the data.
1093
1094
By default the message defined for I in I will be
1095
displayed, but you can also pass your own text.
1096
1097
=cut
1098
1099
######################################################################
1100
1101
sub confirm {
1102
0
0
1
0
my($self,$confirmsg) = @_;
1103
1104
#$self->{confirm} = 1;
1105
0
0
0
$self->{conf}->{CONFIRMSG} = $confirmsg if(defined($confirmsg));
1106
0
0
my $skin_orig = $self->{skin_obj};
1107
0
0
$self->set_skin_obj($self->{skin_obj}->get_confirm_skin());
1108
0
0
$self->make();
1109
0
0
$self->set_skin_obj($skin_orig);
1110
#$self->{confirm} = 0;
1111
0
0
delete $self->{conf}->{CONFIRMSG};
1112
}
1113
1114
#sub text {
1115
# my $self = shift;
1116
#
1117
# my $skin_orig = $self->{skin_obj};
1118
# $self->set_skin_obj($self->{skin_obj}->get_text_skin());
1119
# $self->make();
1120
# $self->set_skin_obj($skin_orig);
1121
#}
1122
1123
######################################################################
1124
1125
=head3 is_confirmed ( )
1126
1127
This method returns true (1) when the form input was affirmed by the
1128
user (see L).
1129
1130
=cut
1131
1132
######################################################################
1133
1134
sub is_confirmed {
1135
0
0
1
0
my($self) = @_;
1136
0
0
0
0
if(defined($self->{input}->{($self->{conf}->{CONFIRMED} || $self->{skin_obj}->get_default('main','CONFIRMED') || $self->{skin_obj}->get_default('default', 'CONFIRMED'))})) {
0
1137
0
0
return 1;
1138
}
1139
0
0
return 0;
1140
}
1141
1142
######################################################################
1143
1144
=head2 Methods For Configuring FormEngine
1145
1146
=head3 set_skin_obj ( OBJECT )
1147
1148
If you want to use an alternative skin, call this method. You've to
1149
pass a valid skin object.
1150
1151
An example: C<$form->set_skin_obj(new HTML::FormEngine::SkinComplex)>.
1152
1153
The default skin object is an instance of
1154
C.
1155
1156
For more information please read L.
1157
1158
Of course this method has to be called before calling L.
1159
1160
=cut
1161
1162
######################################################################
1163
1164
sub set_skin_obj {
1165
0
0
1
0
my($self, $skin) = @_;
1166
0
0
0
if(ref($skin)) {
1167
0
0
$self->{skin_obj} = $skin;
1168
0
0
return 1;
1169
}
1170
0
0
carp("the given data is not a valid skin object!");
1171
0
0
return 0;
1172
}
1173
1174
######################################################################
1175
1176
=head3 get_skin_obj ( )
1177
1178
Returns the currently used skin object.
1179
1180
=cut
1181
1182
######################################################################
1183
1184
sub get_skin_obj {
1185
0
0
1
0
my $self = shift;
1186
0
0
return $self->{skin_obj};
1187
}
1188
1189
######################################################################
1190
1191
=head2 Debug Methods
1192
1193
=head3 set_debug ( DEBUGLEVEL )
1194
1195
Sets the debug level. The higher the value the more output is printed
1196
(to STDERR).
1197
1198
=cut
1199
1200
######################################################################
1201
1202
sub set_debug {
1203
0
0
1
0
my $self = shift;
1204
0
0
$self->{debug} = shift;
1205
}
1206
1207
######################################################################
1208
1209
=head3 get_method ( )
1210
1211
Returns the value of Is METHOD variable (should be I or I).
1212
1213
=cut
1214
1215
######################################################################
1216
1217
sub get_method {
1218
0
0
1
0
my $self = shift;
1219
0
0
0
return $self->{conf}->{METHOD} || $self->{skin_obj}->get_default('main','METHOD') || $self->{skin_obj}->get_default('default', 'METHOD');
1220
}
1221
1222
######################################################################
1223
1224
=head3 get_formname ( )
1225
1226
Returns the value of Is FORMNAME variable. If you have several
1227
FormEngine forms on one page, these forms mustn't have the same
1228
FORMNAME value! You can set it with L.
1229
1230
=cut
1231
1232
######################################################################
1233
1234
sub get_formname {
1235
0
0
1
0
my $self = shift;
1236
0
0
0
return ($self->{conf}->{FORMNAME} || $self->{skin_obj}->get_default('main','FORMNAME') || $self->{skin_obj}->get_default('default','FORMNAME'));
1237
}
1238
1239
######################################################################
1240
1241
=head3 get_conf ( )
1242
1243
Returns a reference to a hash with the current form configuration.
1244
Changing this hash B influence the configuration, because it
1245
is just a copy.
1246
1247
=cut
1248
1249
######################################################################
1250
1251
sub get_conf {
1252
0
0
1
0
my ($self, $field) = @_;
1253
0
0
0
if($field) {
1254
0
0
foreach $_ (keys(%{$self->{conf}->{sub}})) {
0
0
1255
0
0
foreach $_ (@{$self->{conf}->{sub}->{$_}}) {
0
0
1256
0
0
0
if($_->{'NAME'} eq $field) {
1257
0
0
return clone($_);
1258
}
1259
}
1260
}
1261
0
0
return {};
1262
}
1263
0
0
return clone($self->{conf});
1264
}
1265
1266
######################################################################
1267
1268
=head3 print_conf ( HASHREF )
1269
1270
Prints the given form configuration to STDERR.
1271
1272
=cut
1273
1274
######################################################################
1275
1276
sub print_conf {
1277
0
0
1
0
my $self = shift;
1278
0
0
my $conf = shift;
1279
0
0
0
my $i = shift || 0;
1280
0
0
my $y = 0;
1281
0
0
0
if(ref($conf) eq 'ARRAY') {
0
1282
0
0
for($y=0; $y<$i; $y++) { print STDERR " "; }
0
0
1283
0
0
print STDERR "ARRAY\n";
1284
0
0
foreach $_ (@{$conf}) {
0
0
1285
0
0
$self->print_conf($_, $i+1);
1286
}
1287
}
1288
elsif(ref($conf) eq 'HASH') {
1289
0
0
foreach $_ (keys(%{$conf})) {
0
0
1290
0
0
for($y=0; $y<$i; $y++) { print STDERR " "; }
0
0
1291
0
0
print STDERR $_, "\n";
1292
0
0
$self->print_conf($conf->{$_}, $i+1);
1293
}
1294
}
1295
else {
1296
0
0
for($y=0; $y<$i; $y++) { print STDERR " "; }
0
0
1297
0
0
print STDERR $conf, "\n";
1298
}
1299
}
1300
1301
######################################################################
1302
1303
=head2 Special Features
1304
1305
=head3 nesting templates
1306
1307
There are two ways how you can nest templates. The first one is to put
1308
a handler call in the template definition. This is a less flexible
1309
solution, but it might be very usefull. See L
1310
for more information.
1311
1312
The second and flexible way is, to assign a handler call to a template
1313
variable (see L for more information about
1314
handler calls). A good example for this way is hobbies.cgi. There you
1315
have a option called I and an input field to put in the name of
1316
this alternative hobby. When you look at the form definition below,
1317
you see that the value of the I variable of this option is
1318
simply I<<&_text&>>, this is a handler call. So the handler is called
1319
and its return value (in this case the processed C<_text> template) is
1320
assigned to the variable.
1321
1322
The form definition of hobbies.cgi:
1323
1324
my @form = (
1325
{
1326
templ => 'check',
1327
NAME => 'hobbie',
1328
TITLE => 'Hobbies',
1329
OPTION => [['Parachute Jumping', 'Playing Video Games'], ['Doing Nothing', 'Soak'], ['Head Banging', 'Cat Hunting'], "Don't Know", '<&_text&>'],
1330
OPT_VAL => [[1,2], [3,4], [5,6], 7, 8],
1331
VALUE => [1,2,7],
1332
'sub' => {'_text' => {'NAME' => 'Other', 'VALUE' => '', ERROR => ''}},
1333
ERROR_IN => sub{if(shift eq 4) { return "That's not a faithfull hobby!" }}
1334
}
1335
);
1336
1337
If you have a closer look at the form definition above, you'll
1338
recognize that there is a key called 'sub'. With help of this key you
1339
can define the variables of the nested templates. If the nested
1340
templates don't use the same variable names as their parents, you
1341
don't need that, because then you can assign these variables on the
1342
same level with the parents template variables.
1343
1344
=cut
1345
1346
######################################################################
1347
# INTERNAL METHODS #
1348
######################################################################
1349
1350
#this method is called by the constructor in initializes the object variables and settings
1351
sub _initialize {
1352
1
1
2
my ($self,$input) = @_;
1353
1354
#
1355
1
7
Hash::Merge::set_behavior('LEFT_PRECEDENT');
1356
1357
# the form input
1358
1
33
$self->{input} = {};
1359
1
5
$self->set_input($input);
1360
# count of errors
1361
1
2
$self->{errcount} = 0;
1362
# whether to display the input again after the form was submitted
1363
1
4
$self->{use_input} = 1;
1364
# whether to check the input
1365
1
2
$self->{check_error} = 1;
1366
# the html/xhtml form code
1367
1
2
$self->{cont} = '';
1368
# the form configuration/layout
1369
1
3
$self->{conf} = {};
1370
# need for set_main_vars()
1371
1
3
$self->{conf_main} = {};
1372
# whether the make() method has to be called before returning the generated html/xhtml code (see get() method)
1373
1
3
$self->{call_make} = 0;
1374
# whenever the make() method is called the functions listed referenced in this array are being called too
1375
$self->{call_before_make} = [
1376
sub {
1377
0
0
0
my($self) = @_;
1378
0
0
$self->{values} = {};
1379
0
0
$self->{nconf} = {'main' => [clone($self->{conf})]};
1380
0
0
$self->{varstack} = [];
1381
0
0
$self->{varstack_defaults} = [];
1382
}
1383
1
37
];
1384
1385
# the level of nested templates that we currently are in (templates starting with "_" don't count)
1386
1
3
$self->{depth} = 0;
1387
# whether a special field-content should be submitted with the user made input to seperate fields with the same name from each other
1388
1
3
$self->{seperate} = 0;
1389
# object variables that have to be reseted to 0 when the "#seperate" handler is called and a field-seperation code is returned
1390
1
2
$self->{reset_on_seperate} = [];
1391
# saves the iteration count per global loop (loops that don't specify any variables) (see e.g. Skin.pm for more information on loops)
1392
1
3
$self->{loop} = [];
1393
# saves the iteration count foreach variable on all loop levels
1394
1
3
$self->{loop_var} = {};
1395
# if on a certain global loop level at least one variable has a next element, this is setted to 1 for that level which means
1396
# that the loop will be executed again
1397
1
2
$self->{loop_deep} = [];
1398
# this is the same as loop_deep but for none-global loops that means for loops which do specify special variables on which they iterate
1399
# then its saved per variable and its enough if only one variable has another element for the loop to be executed again
1400
1
3
$self->{loop_deep_var} = {};
1401
# this is for future release, there'll be a feature to say that if one variable has not a next element the loop should be finished.
1402
1
9
$self->{loop_deep2} = [];
1403
1404
# see e.g. Skin.pm for possibilities on how to modify the skin
1405
1
18
$self->set_skin_obj(new HTML::FormEngine::SkinClassic);
1406
}
1407
1408
# this function is for child classes of FormEngine.pm, instead of the constructor they should overwrite this function,
1409
# so that the original constructor of this class is still called
1410
0
0
sub _initialize_child {};
1411
1412
sub _check_conf {
1413
# the array notation is more user friendly
1414
# here we rewrite it into the internal hash notation.
1415
# users are allowed to use the more flexible but also more complicated
1416
# hash notation directly.
1417
1418
0
0
my ($self,$conf) = @_;
1419
0
my ($templ, $tmp);
1420
1421
#an array of field definitions is transformed into an internal useable hash
1422
0
0
0
if(ref($conf) eq 'ARRAY' && ref($conf->[0]) eq 'HASH') {
0
0
0
0
1423
0
my %cache = ();
1424
0
$cache{'sub'} = {};
1425
0
$cache{'TEMPL'} = [];
1426
0
foreach $_ (@{$conf}) {
0
1427
#default template is 'text'
1428
0
0
$templ = $_->{templ}||$self->{skin_obj}->get_default('default','templ');
1429
0
delete $_->{templ};
1430
#hidden templates must be handled special so that they don't use any visible space
1431
0
0
if($self->{skin_obj}->is_hidden($templ)) {
1432
0
0
$cache{'HIDDEN'} = [] unless(ref($cache{'HIDDEN'}) eq 'ARRAY');
1433
0
push @{$cache{'HIDDEN'}}, "<&$templ&>";
0
1434
}
1435
#TEMPL is a special variable which contains the list of subtemplates
1436
else {
1437
0
push @{$cache{'TEMPL'}}, "<&$templ&>";
0
1438
}
1439
0
0
if(ref($cache{sub}->{$templ}) ne 'ARRAY') {
1440
0
$cache{sub}->{$templ} = [];
1441
}
1442
0
push @{$cache{sub}->{$templ}}, $self->_check_conf($_);
0
1443
}
1444
0
$conf = \%cache;
1445
}
1446
#hash notation is already used
1447
elsif(ref($conf) eq 'HASH' && ref($conf->{sub}) eq 'HASH') {
1448
0
0
$conf->{TEMPL} = [] unless(ref($conf->{TEMPL}) eq 'ARRAY');
1449
0
foreach $_ (keys(%{$conf->{sub}})) {
0
1450
0
0
if(ref($conf->{sub}->{$_}) eq 'HASH') {
0
1451
0
$conf->{sub}->{$_} = [$self->_check_conf($conf->{sub}->{$_})];
1452
}
1453
elsif(ref($conf->{sub}->{$_}) eq 'ARRAY') {
1454
0
foreach $_ (@{$conf->{sub}->{$_}}) {
0
1455
0
0
$_ = $self->_check_conf($_) if(ref($_) eq 'HASH');
1456
}
1457
}
1458
}
1459
}
1460
#transform to hash notation and fillup TEMPL resp HIDDEN
1461
elsif(ref($conf) eq 'HASH' && ref($conf->{sub}) eq 'ARRAY') {
1462
0
$tmp = $self->_check_conf($conf->{sub});
1463
0
0
if(ref($tmp) eq 'HASH') {
1464
0
$conf->{sub} = $tmp->{sub};
1465
0
$conf->{TEMPL} = $tmp->{TEMPL};
1466
0
$conf->{HIDDEN} = $tmp->{HIDDEN};
1467
}
1468
}
1469
1470
#NEW --- TESTING ----
1471
1472
#if(ref($conf->{OPTION}) eq 'HASH') {
1473
# if(!defined($conf->{OPT_VAL})) {
1474
# my @option;
1475
# foreach $_ (keys(%{$conf->{OPTION}})) {
1476
# #...
1477
# }
1478
# } else {
1479
# carp "want to rewrite OPTION-Hash to OPTION-Array and OPT_VAL-Array, but OPT_VAL is already being used!";
1480
# }
1481
#}
1482
1483
0
return $conf;
1484
}
1485
1486
sub _get_var {
1487
# here we go through the variable stack (from highest to lowest level)
1488
# we break out of the loop if a value was found.
1489
# "varstack_defaults" contains the defaults and is searched when we don't find a certain value on the normal varstack
1490
# we return undef if there is no value defined for a certain variable
1491
1492
0
0
my ($self,$var,@history) = @_;
1493
0
my $res = undef;
1494
1495
0
0
return $res unless($var ne '');
1496
1497
#TEMPL and HIDDEN must be handled special since they're only valid on the level where they're defined
1498
0
0
0
if($var eq 'TEMPL' || $var eq 'HIDDEN') {
1499
0
0
$res = defined($self->{varstack}->[-1]->{$var}) ? $self->_get_var_elem($var, $self->{varstack}->[-1]->{$var}) : undef;
1500
} else {
1501
1502
0
my $value = undef;
1503
0
for(my $i=@{$self->{varstack}} - 1; $i>=0; $i--) {
0
1504
0
0
if(defined($self->{varstack}->[$i]->{$var})) {
1505
0
$res = $self->_get_var_elem($var, $self->{varstack}->[$i]->{$var});
1506
0
last;
1507
}
1508
}
1509
1510
0
0
if(!defined($res)) {
1511
#nothing found on normal varstack, lets search in the defaults
1512
0
for (my $i=@{$self->{varstack_defaults}} -1; $i>=0; $i--) {
0
1513
0
0
if(defined($self->{varstack_defaults}->[$i]->{$var})) {
1514
0
$res = $self->_get_var_elem($var, $self->{varstack_defaults}->[$i]->{$var});
1515
0
last;
1516
}
1517
}
1518
}
1519
}
1520
1521
#recognizing endless recursions
1522
0
0
0
if(defined($res) && ref($res) eq '') {
1523
0
0
0
return undef if(@history && grep {$res =~ m/<&$_&>/} @history);
0
1524
0
$res = $self->_parse($res, @history, $var);
1525
}
1526
1527
#if nothing is found at all $res is undef
1528
0
return $res;
1529
}
1530
1531
# sometimes variables contain arrays. this method returns the right array element due to the loop level and status.
1532
# it is called by _get_var()
1533
sub _get_var_elem {
1534
0
0
my($self, $var, $res) = @_;
1535
0
0
0
if(ref($res) eq 'ARRAY' and defined($self->{loop_var}->{$var}) || @{$self->{loop}} > 0) {
0
1536
0
my $loop;
1537
0
my $flag = 0;
1538
0
0
if(defined($self->{loop_var}->{$var})) {
0
1539
0
$loop = $self->{loop_var}->{$var};
1540
}
1541
elsif($var ne 'TEMPL') {
1542
0
$loop = $self->{loop};
1543
0
$flag = 1;
1544
}
1545
1546
0
0
if(ref($loop) eq 'ARRAY') {
1547
0
for(my $i = 0; $i<@{$loop}; $i++) {
0
1548
0
0
if(defined($res->[$loop->[$i] +1])) {
0
1549
0
0
$flag ? $self->{loop_deep}->[$i] = 1 : $self->{loop_deep_var}->{$var}->[$i] = 1;
1550
}
1551
elsif($flag) {
1552
0
$self->{loop_deep2}->[$i] = 0;
1553
}
1554
0
$res = $res->[$loop->[$i]];
1555
0
0
return '' unless(defined($res));
1556
0
0
if(ref($res) ne 'ARRAY') {
1557
0
return $res;
1558
}
1559
}
1560
}
1561
}
1562
0
return $res;
1563
}
1564
1565
# this function sets an (variable,value) pair on the current stack level
1566
# it can be usefull for certain handlers (see Handler.pm)
1567
sub _set_var {
1568
0
0
my ($self,$var,$value) = @_;
1569
0
0
print "$var => $value\n" if($self->{debug});
1570
0
$self->{varstack}->[@{$self->{varstack}} -1]->{$var} = $value;
0
1571
}
1572
1573
sub _parse {
1574
# here the templates are parsed into one resulting form, following the given configuration
1575
# this job is realized by calling _parse recursive
1576
1577
# $cont contains the string which is to be parsed/interpreted
1578
# @history is passed when replacing <&[A-Z]&> variables, it is used to avoid endless recursions
1579
0
0
my ($self,$cont, @history) = @_;
1580
1581
# the current char
1582
0
my $p = '';
1583
# the old char
1584
0
my $old = '';
1585
# contents of a certain area (like <& ..content.. &>)
1586
0
my $match = '';
1587
# position where the area started
1588
0
my $c = 0;
1589
# areas (sections) can be nested, %f just saves the level of nesting foreach area type (&, ~ and !)
1590
0
my %f;
1591
1592
0
0
$cont = '' unless(defined($cont));
1593
0
for(my $i=0; $i
1594
0
$old = $p;
1595
0
$p = substr($cont,$i,1);
1596
0
0
$match .= $p if($c);
1597
#here we find a starting tag like <& or <~ or
1598
0
0
0
($c == 0 ? ($c=$i) : 1) && ++$f{$p} && next if($old eq '<' and grep {$p eq $_} ('&','~','!'));
0
0
0
0
1599
#here it is closed: &> or ~> or !>
1600
0
0
0
if($c > 0 and grep {$old eq $_} ('&','~','!') and $p eq '>') {
0
0
1601
0
my $res = undef;
1602
0
$f{$old}--;
1603
#none of the < .. > sections must be opened! for every <(&|~|!) there must be a matching (&|~|!)>
1604
0
0
unless(grep {$_ > 0} values(%f)) {
0
1605
# replace variables with theire values
1606
0
0
if($match =~ m/^([A-Z_]+)&>$/) {
0
0
0
1607
# @history, $1 is passed do recognize endless recursions
1608
0
$res = $self->_get_var($1,@history,$1);
1609
0
0
$res = '' unless(defined($res));
1610
}
1611
# handler calls
1612
elsif($match =~ m/^(.*)&>$/) {
1613
0
local $_ = $self->_parse($1);
1614
0
0
if(m/^(#?[a-z_]+[a-z_0-9]+)(?: (.*?))?$/) {
1615
0
my $templ = $1;
1616
0
my $args = $2;
1617
0
my @args;
1618
0
0
if(defined($args)) {
1619
#we must prevent escaped commas from being interpreted
1620
0
$args =~ s/\\,/#"\!§\$/g;
1621
#get list of arguments
1622
0
@args = split(/,/,$args);
1623
0
0
push @args, '' if($args =~ m/^,$/);
1624
#replace escaped commas with normal commas
1625
0
local $_;
1626
0
foreach $_ (@args) { s/#"\!§\$/,/g; }
0
1627
}
1628
1629
0
my $pupo = 0;
1630
0
my $pupo_defaults = $self->_push_varstack($self->{skin_obj}->get_default($templ), 'varstack_defaults');
1631
0
my $nconf_back = $self->{nconf};
1632
1633
0
0
0
if(ref($self->{nconf}->{$templ}) eq 'ARRAY' && ref($self->{nconf}->{$templ}->[0]) eq 'HASH') {
1634
1635
# define new nconf
1636
0
0
if(ref($self->{nconf}->{$templ}->[0]->{sub}) eq 'HASH') {
1637
1638
# in case that we go on a deeper level we have to get the definitions for that level (_parse() works recursive)
1639
0
$self->{nconf} = $self->{nconf}->{$templ}->[0]->{sub};
1640
1641
} else {
1642
#not sure if that's a good idea. its a bugfix.
1643
0
$self->{nconf} = {};
1644
}
1645
1646
# soon we will store the definitions for the found subtemplate on the variable stack.
1647
# sub isn't a variable, behind this key the subsubtemplate definitions are stored, those
1648
# we allready extracted above.
1649
# so we now delete this key to prevent it from being pushed on the variable stack.
1650
0
0
if(defined($nconf_back->{$templ}->[0]->{sub})) {
1651
0
delete $nconf_back->{$templ}->[0]->{sub};
1652
}
1653
# shift is important! so next time the definition underneath will be the first one and thus be grabbed
1654
0
my $cache = shift @{$nconf_back->{$templ}};
0
1655
1656
# push the (completed) definitions
1657
0
$pupo = $self->_push_varstack($cache);
1658
}
1659
1660
0
my $handler;
1661
# set handler
1662
0
0
if(! ($handler = $self->{skin_obj}->get_handler($templ))) {
1663
0
$handler = $self->{skin_obj}->get_handler('default');
1664
}
1665
1666
#TEMPL and HIDDEN are only valid on one level so we also have to set the loop-level and status back to default
1667
0
my $loop_templ_back = [$self->{loop_var}->{TEMPL}, $self->{loop_var}->{HIDDEN}];
1668
0
my $loop_deep_templ_back = [$self->{loop_deep_var}->{TEMPL}, $self->{loop_deep_var}->{HIDDEN}];
1669
0
$self->{loop_var}->{TEMPL} = [];
1670
0
$self->{loop_var}->{HIDDEN} = [];
1671
0
$self->{loop_deep_var}->{TEMPL} = [];
1672
0
$self->{loop_deep_var}->{HIDDEN} = [];
1673
1674
#templates that begin with _ do not count
1675
0
0
unless($templ =~ m/^_/) {
1676
0
$self->{depth} ++;
1677
0
$res = &$handler($self,$templ,@args);
1678
0
$self->{depth} --;
1679
1680
} else {
1681
0
$res = &$handler($self,$templ,@args);
1682
}
1683
1684
#above we setted these settings to default because we were changing levels, now that we're back we have to set the original settings again
1685
0
$self->{loop_var}->{TEMPL} = $loop_templ_back->[0];
1686
0
$self->{loop_var}->{HIDDEN} = $loop_templ_back->[1];
1687
0
$self->{loop_deep_var}->{TEMPL} = $loop_deep_templ_back->[0];
1688
0
$self->{loop_deep_var}->{HIDDEN} = $loop_deep_templ_back->[1];
1689
1690
0
0
$res = '' unless(defined($res));
1691
1692
#we're back
1693
0
$self->{nconf} = $nconf_back;
1694
1695
# pop as many as there were pushed before (can only be 0 or 1)
1696
0
$self->_pop_varstack($pupo);
1697
0
$self->_pop_varstack($pupo_defaults, 'varstack_defaults');
1698
} else {
1699
#the <&&> is empty... i'm not sur if its a good idea ... but we replace it by nothing:
1700
0
$res = '';
1701
}
1702
}
1703
# parse loops
1704
elsif($match =~ m/^(.*)~([A-Z_ ]*)~>$/s) {
1705
0
my $body = $1;
1706
0
my @itvars = split(' ', $2);
1707
# a global loop, no loop variables defined so we loop over all variables
1708
0
0
if(!@itvars) {
1709
0
push @{$self->{loop}}, 0;
0
1710
0
$self->{loop_deep}->[@{$self->{loop}}-1] = 0;
0
1711
0
$self->{loop_deep2}->[@{$self->{loop}}-1] = 1;
0
1712
0
foreach $_ (keys(%{$self->{loop_var}})) {
0
1713
0
push @{$self->{loop_var}->{$_}}, 0;
0
1714
0
$self->{loop_deep_var}->{$_}->[@{$self->{loop_var}->{$_}}-1] = 0;
0
1715
}
1716
}
1717
else {
1718
0
foreach $_ (@itvars) {
1719
0
0
unless(defined($self->{loop_var}->{$_})) {
1720
0
$self->{loop_var}->{$_} = [];
1721
0
0
$self->{loop_deep_var}->{$_} = [] unless(defined($self->{loop_deep_var}->{$_}));
1722
# we copy the global status into the new variable statuses, its easier to handle like that
1723
#TEMPL and HIDDEN are only valid on one level and should not be affected by global loops
1724
0
0
0
if($_ ne 'TEMPL' && $_ ne 'HIDDEN') {
1725
0
for(my $i=0; $i<@{$self->{loop}}; $i++) {
0
1726
0
$self->{loop_var}->{$_}->[$i] = $self->{loop}->[$i];
1727
0
$self->{loop_deep_var}->{$_}->[$i] = $self->{loop_deep}->[$i];
1728
}
1729
}
1730
}
1731
0
push @{$self->{loop_var}->{$_}}, 0;
0
1732
0
$self->{loop_deep_var}->{$_}->[@{$self->{loop_var}->{$_}}-1] = 0;
0
1733
}
1734
}
1735
1736
0
$res = '';
1737
0
while(1) {
1738
# parse and append
1739
0
$res .= $self->_parse($body);
1740
0
0
if(!@itvars) {
1741
0
0
unless($self->{loop_deep}->[@{$self->{loop}}-1]) {
0
1742
0
my $flag = 0;
1743
0
foreach $_ (keys(%{$self->{loop_var}})) {
0
1744
0
0
do {$flag=1; last;} if($self->{loop_deep_var}->{$_}->[@{$self->{loop_var}->{$_}}-1]);
0
0
0
1745
}
1746
0
0
do {last;} unless($flag);
0
1747
}
1748
0
$self->{loop}->[-1] ++;
1749
0
foreach $_ (keys(%{$self->{loop_var}})) {
0
1750
0
$self->{loop_deep_var}->{$_}->[@{$self->{loop_var}->{$_}}-1] = 0;
0
1751
0
$self->{loop_var}->{$_}->[@{$self->{loop_var}->{$_}}-1] ++;
0
1752
}
1753
0
$self->{loop_deep}->[@{$self->{loop}}-1] = 0;
0
1754
}
1755
else {
1756
0
my $flag = 0;
1757
0
foreach $_ (@itvars) {
1758
0
0
do {$flag=1; last;} if($self->{loop_deep_var}->{$_}->[@{$self->{loop_var}->{$_}}-1]);
0
0
0
1759
}
1760
0
0
do {last;} if(!$flag);
0
1761
0
foreach $_ (@itvars) {
1762
0
$self->{loop_deep_var}->{$_}->[@{$self->{loop_var}->{$_}}-1] = 0;
0
1763
0
$self->{loop_var}->{$_}->[-1] ++;
1764
}
1765
}
1766
}
1767
1768
0
0
if(!@itvars) {
1769
0
pop @{$self->{loop}};
0
1770
0
foreach $_ (keys(%{$self->{loop_var}})) {
0
1771
0
pop @{$self->{loop_var}->{$_}};
0
1772
}
1773
}
1774
else {
1775
0
foreach $_ (@itvars) {
1776
0
pop @{$self->{loop_var}->{$_}};
0
1777
0
0
delete $self->{loop_var}->{$_} unless(@{$self->{loop_var}->{$_}});
0
1778
}
1779
}
1780
}
1781
# parse sections
1782
elsif($match =~ m/^(.*)\!(?:([A-Z_ ]+)|([A-Z_\|]+))\!>$/s) {
1783
0
my $code = $1;
1784
0
my $tmp = 0;
1785
0
$res = '';
1786
0
0
0
if(defined($2) and $2 ne '') {
0
0
1787
0
local $_ = $2;
1788
#check all variables, all must have a scalar value (ARRAYS are not allowed)
1789
0
foreach $_ (split(' ',$_)) {
1790
0
$_ = $self->_get_var($_);
1791
0
0
0
++$tmp && last unless(defined($_) and $_ ne '' and !ref($_));
0
0
1792
}
1793
0
0
$res = $code unless($tmp);
1794
}
1795
elsif(defined($3) and $3 ne '') {
1796
0
$_ = $3;
1797
#check all variables, one of them must have a scalar value (ARRAYS are not allowed)
1798
0
foreach $_ (split('\|',$_)) {
1799
0
$_ = $self->_get_var($_);
1800
0
0
0
++$tmp && last if(defined($_) and $_ ne '' and !ref($_));
0
0
1801
}
1802
0
0
$res = $code if($tmp);
1803
}
1804
0
0
$res = $self->_parse($res) if($res ne '');
1805
}
1806
1807
#a variable-value found? a handler called? a section interpreted?
1808
0
0
if(defined($res)) {
1809
1810
#a little bit dirty: if $res is an array and everything is replaced by it we return it as array and not as string
1811
#this is necessary to support default settings like "OPT_VAL => <&OPTION&>"... if we wouldn't do it a string like 'ARRAY0xff45' would be returned if OPTION is an ARRAY
1812
0
0
0
if(ref($res) eq 'ARRAY' && $c==1 && $i == length($cont)-1) {
0
1813
0
return $res;
1814
}
1815
1816
#we have to replace the <(&|~|!) ... (&|~|!)> stuff with the result
1817
#$c contains the position of the first (&|~|!) $i the position of the last
1818
0
$cont = substr($cont,0,$c-1) . $res . substr($cont,$i+1);
1819
#we've to add the length diffrence between the code and the result
1820
0
$i += length($res)-length($match)-2;
1821
}
1822
#reset variables
1823
0
$match = '';
1824
0
$c = 0;
1825
}
1826
}
1827
}
1828
0
return $cont;
1829
}
1830
1831
#create a new level on the variable stack and fill it with the given values
1832
sub _push_varstack {
1833
0
0
my ($self,$add, $name) = @_;
1834
0
0
if(ref($add) eq 'HASH') {
1835
#DEBUGGING
1836
0
0
if($self->{debug}) {
1837
0
local $_;
1838
0
foreach $_(keys(%{$add})) {
0
1839
0
0
for(my $i=0; $i<@{$self->{$name||'varstack'}}; $i++) {
0
1840
0
print STDERR " ";
1841
}
1842
0
print STDERR "$_:", $add->{$_}, "\n";
1843
}
1844
}
1845
1846
# the following code is a little hack to make writing form configurations a bit easier and more logic
1847
# the sub-sections seem to be independ because recursion-layers are automatically added
1848
0
local $_;
1849
0
foreach $_ (keys(%{$add})) {
0
1850
#TEMPL and HIDDEN are valid only for one level anyway so we must not care about them
1851
0
0
0
if($_ ne 'TEMPL' and $_ ne 'HIDDEN') {
1852
0
0
if(ref($add->{$_}) eq 'ARRAY') {
1853
0
my $max;
1854
0
0
if(defined($self->{loop_var}->{$_})) {
1855
0
$max = @{$self->{loop_var}->{$_}};
0
1856
} else {
1857
0
$max = @{$self->{loop}};
0
1858
}
1859
0
for(my $i=0; $i<$max; $i++) {
1860
0
$add->{$_} = [$add->{$_}];
1861
}
1862
}
1863
}
1864
}
1865
1866
0
0
push @{$self->{$name||'varstack'}}, $add;
0
1867
0
return 1;
1868
}
1869
0
return 0;
1870
}
1871
1872
#remove level(s) from the variable stack (starting from the highest)
1873
sub _pop_varstack {
1874
0
0
my ($self,$howmany,$name) = @_;
1875
0
my $i;
1876
0
for($i=0; $i<$howmany; $i++) {
1877
#DEBUGGING
1878
0
0
if($self->{debug}) {
1879
0
print STDERR "rm\n";
1880
}
1881
0
0
pop @{$self->{$name||'varstack'}};
0
1882
}
1883
0
return $i;
1884
}
1885
1886
# returns the value for the currently parsed field
1887
sub _get_value {
1888
0
0
my ($self,$namevar,$valuevar,$force) = @_;
1889
0
my $res;
1890
1891
0
0
$valuevar = 'VALUE' unless(defined($valuevar));
1892
0
0
$namevar = 'NAME' unless(defined($namevar));
1893
1894
#force_value forces to not return the submitted, but to return the configured value
1895
#$force forces to return the submitted in any case
1896
0
0
0
if(($self->is_submitted && $self->{use_input} && !$self->_get_var('force_value')) || $force) {
0
0
1897
0
local $_ = $self->_get_var($namevar);
1898
0
$res = $self->_get_input($_);
1899
#$self->{values} is increased with by the seperate handler
1900
0
0
0
$res = $res->[$self->{values}->{$_}||0] if(ref($res) eq 'ARRAY');
1901
}
1902
else {
1903
#return the configured (default) value
1904
0
$res = $self->_get_var($valuevar);
1905
}
1906
1907
0
0
return defined($res) ? $res : ''
1908
}
1909
1910
#adds a new field to the end of the form
1911
sub _add_to_output {
1912
0
0
my($self,$templ,$def) = @_;
1913
0
0
0
if($templ && ref($def) eq 'HASH') {
1914
#add the template
1915
0
push @{$self->{conf}->{TEMPL}}, '<&' . $templ . '&>';
0
1916
0
0
$self->{conf}->{sub}->{$templ} = [] unless (ref($self->{conf}->{sub}->{$templ}) eq 'ARRAY');
1917
#add the definition
1918
0
push @{$self->{conf}->{sub}->{$templ}}, $def;
0
1919
0
0
$self->{call_make} = 1 if($self->{cont});
1920
}
1921
}
1922
1923
#this methods turns an n-dimensional array into an 1 dimensional
1924
sub _flatten_array {
1925
0
0
my($self,@array) = @_;
1926
0
my @res;
1927
0
foreach $_ (@array) {
1928
0
0
(ref($_) ne 'ARRAY') ? (push @res, $_) : (push @res, $self->_flatten_array(@$_));
1929
}
1930
0
return @res;
1931
}
1932
1933
#this function is called by get_input
1934
sub _get_input {
1935
0
0
my ($self,$fname) = @_;
1936
0
0
0
if(defined($fname) and $fname ne '') {
1937
0
0
if(ref($self->{input}->{$fname}) eq 'ARRAY') {
1938
0
my $res = [];
1939
0
my @tmp = ();
1940
0
for(my $i = 0; $i<@{$self->{input}->{$fname}}; $i++) {
0
1941
0
local $_ = $self->{input}->{$fname}->[$i];
1942
#SEPVAL seperates the value groups which belong together
1943
0
0
0
push @tmp, $_ if((!$self->{seperate}) or ($_ ne ($self->{conf}->{SEPVAL} || $self->{skin_obj}->get_default('main','SEPVAL'))));
0
1944
0
0
0
if($_ eq ($self->{conf}->{SEPVAL} || $self->{skin_obj}->get_default('main','SEPVAL')) or $i+1 == @{$self->{input}->{$fname}}) {
0
0
1945
0
0
push @$res, @tmp > 1 ? [@tmp] : @tmp;
1946
0
@tmp = ();
1947
}
1948
}
1949
0
return $res;
1950
}
1951
else {
1952
0
0
0
return (defined($self->{input}->{$fname}) and (!$self->{seperate} or $self->{input}->{$fname} ne ($self->{conf}->{SEPVAl} || $self->{skin_obj}->get_default('main', 'SEPVAL')))) ? $self->{input}->{$fname} : undef;
1953
}
1954
}
1955
0
return undef;
1956
}
1957
1958
######################################################################
1959
1960
=head1 EXTENDING FORMENGINE
1961
1962
=head2 Modify A Skin
1963
1964
To set the current skin, use the method L. To
1965
Modify it you should have a look at L.
1966
1967
=head2 Extending Or Writing A Skin
1968
1969
Have a look at L for this task and especially
1970
read its source code and the code and documentation of the other skin
1971
packages. You can easily change the layout by copying the skin hash,
1972
fitting the html code to your needs and then using L
1973
OBJECT )> to overwrite the default. Please send me your skins.
1974
1975
=head2 Write A Handler
1976
1977
Read L. Also read L
1978
on how to make the handler available. To make it persistent see
1979
L.
1980
1981
=head2 Write A Check Routine
1982
1983
The design of a check routine is explained in
1984
L. You can easily refer to it by reference
1985
or even define it in line as an anonymous function (see the ERROR
1986
template variable). If your new written routine is of general usage,
1987
you should make it part of FormEngine by placing it in Checks.pm and
1988
refering to it from Skin.pm. For more read L.
1989
Please send me your check methods!
1990
1991
=head1 MORE INFORMATION
1992
1993
Have a look at ...
1994
1995
=over
1996
1997
=item
1998
1999
L, L,
2000
L,
2001
L,
2002
L and the modules source code
2003
for information about FormEngines template and skin system.
2004
2005
=item
2006
2007
L and the modules source code for
2008
information about FormEngines handler architecture.
2009
2010
=item
2011
2012
L and the modules source code for
2013
information about FormEngines check methods.
2014
2015
=back
2016
2017
=head1 BUGS
2018
2019
Please use L
2020
to inform you about reported bugs and to report bugs.
2021
2022
If it doesn't work feel free to email directly to
2023
moritz@freesources.org.
2024
2025
Thanks!
2026
2027
=head1 AUTHOR
2028
2029
(c) 2003-2004, Moritz Sinn. This module is free software; you can
2030
redistribute it and/or modify it under the terms of the GNU General
2031
Public License (see http://www.gnu.org/licenses/gpl.txt) as published
2032
by the Free Software Foundation; either version 2 of the License, or
2033
(at your option) any later version.
2034
2035
This module is distributed in the hope that it will be useful, but
2036
WITHOUT ANY WARRANTY; without even the implied warranty of
2037
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
2038
General Public License for more details.
2039
2040
I am always interested in knowing how my work helps others, so if you
2041
put this module to use in any of your own code please send me the
2042
URL. If you make modifications to the module because it doesn't work
2043
the way you need, please send me a copy so that I can roll desirable
2044
changes into the main release.
2045
2046
Please use L
2047
for comments, suggestions and bug reports. If it doesn't work feel
2048
free to mail to moritz@freesources.org.
2049
2050
=head1 CREDITS
2051
2052
Special thanks go to Darren Duncan. His HTML::FormTemplate module gave
2053
me a good example how to write a documentation. There are several
2054
similarities between HTML::FormEngine and HTML::FormTemplate, we both
2055
came to an related API design, the internal processes are completly
2056
diffrent. It wasn't my purpose to have these api design decisions in
2057
common with HTML::FormTemplate. When i wrote the php version of
2058
HTML::FormEngine, i didn't know anything about
2059
HTML::FormTemplate. Later i just ported this php class to perl. I
2060
think we both came to an likewise API because its just the most
2061
obvious solution.
2062
2063
Features which FormEngine has and FormTemplate hasn't:
2064
2065
=over
2066
2067
=item
2068
2069
Skinsystem
2070
2071
=item
2072
2073
More flexible validation and error message report
2074
2075
=item
2076
2077
Common checking methods are predefined, others can be added on the fly
2078
2079
=item
2080
2081
Internationalization with help of gettext
2082
2083
=item
2084
2085
Due to the handler system and the modular design FormEngine can easily
2086
be extended
2087
2088
=item
2089
2090
A flexible set of methods to let the user confirm his input
2091
2092
=back
2093
2094
Features which FormTemplate has and FormEngine hasn't:
2095
2096
I
2097
2098
(I asked the author to send me some notes, he told me he'll do so at
2099
opportunity.)
2100
2101
=head1 SEE ALSO
2102
2103
HTML::FormTemplate by Darren Duncan
2104
2105
=cut
2106
2107
1;
2108
2109
__END__