← Back to branch summary

~ubuntu-branches/debian/sid/libembperl-perl/sid

« back to all changes in this revision

Viewing changes to Embperl/Form.pm

  • Committer: Bazaar Package Importer
  • Author(s): Gunnar Wolf, Jonathan Yu, Damyan Ivanov, Ryan Niebur, gregor herrmann, Gunnar Wolf
  • Date: 2009-10-15 11:43:24 UTC
  • mfrom: (1.2.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20091015114324-2rnqzsj9jmpwd9nt
Tags: 2.3.0-1
http://bugs.debian.org/543609
http://bugs.debian.org/521971
http://bugs.debian.org/412521
[ Jonathan Yu ]
* New upstream release
  + SSI syntax now behaves more like mod_include
  + Improved XHTML/XML support
  + Fix to correctly retrieve Cookie header under apache2
  + Fix segfault when a value of an input attribute is removed
* Bringing this package under the pkg-perl group (Closes: #543609)
* Updated d/watch with CPAN search site
* Standards-Version 3.8.3
  + Remove version dependency on perl
  + Add Vcs-* and Homepage fields
* Drop version dependency on:
  + apache2-prefork-dev (>= 2.2.3-3.3) [oldstable 2.2.3-4]
  + apache2-mpm-prefork (>= 2.2.3-3.3) [oldstable  2.2.3-4]
  + libapache2-mod-perl2 (>= 2.0.2-2.3) [oldstable 2.0.2-2.4]
* Remove libcgi-pm-perl | perl-modules (>= 5.8.0) | libcgi-perl,
  which is always satisfied by perl
* Add extensive patches to fix POD errors and add whatis entries
* Add a patch to remove some Unicode data from POD; it was causing
  an obscure error with `AE' (thanks Ryan52!)

[ Damyan Ivanov ]
* debian/rules: fix target dependencies

[ Ryan Niebur ]
* Update jawnsy's email address
* Update ryan52's email address

[ gregor herrmann ]
* Split out all changes to upstream code into proper patches managed by
  quilt.
* Add patch cgi_pm.patch by Niko Tyni to avoid FTBFS if a newer CGI.pm is
  present at test time (closes: #521971).
* Update debian/copyright.
* debian/rules:
  - clean up a bit
  - call make with "-j1", the upstream build system is not parallel-build safe
  - add support for DEB_BUILD_OPTIONS nocheck
* Change Section to "perl".
* Remove dbinitembperlapache (created by test suite).

[ Gunnar Wolf ]
* Updated README.Debian to reflect the current reality re: thread
  safety, dropping mentions of obsolete mod_perl v1 and mentioning the
  deprecation of embperl itself
* Reload Apache if a2enmod/a2dismod was called in postinst/prerm
* Added Suggests: apache2-mpm-prefork, as it is the closer we can get to
  get the non-threaded versions of Apache2 by default besides
  documenting, which is already done in README.Debian. (Closes: #412521)

Show diffs side-by-side

added added

removed removed

Lines of Context:
Embperl/Form.pm
1
 
 
2
 
###################################################################################
3
 
#
4
 
#   Embperl - Copyright (c) 1997-2005 Gerald Richter / ecos gmbh   www.ecos.de
5
 
#
6
 
#   You may distribute under the terms of either the GNU General Public
7
 
#   License or the Artistic License, as specified in the Perl README file.
8
 
#
9
 
#   THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
10
 
#   IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
11
 
#   WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
12
 
#
13
 
#   $Id$
14
 
#
15
 
###################################################################################
16
 
 
17
 
 
18
 
package Embperl::Form ;
19
 
 
20
 
use strict ;
21
 
 
22
 
use lib qw{..} ;
23
 
 
24
 
use Embperl ;
25
 
use Embperl::Form::Control ;
26
 
use Embperl::Form::Validate ;
27
 
use Embperl::Form::Control::blank ;
28
 
 
29
 
use Embperl::Inline ;
30
 
 
31
 
use Data::Dumper ;
32
 
 
33
 
our %forms ;
34
 
our %CLEANUP = ('forms' => 0) ;
35
 
 
36
 
# ---------------------------------------------------------------------------
37
 
#
38
 
#   new - create a new form
39
 
#
40
 
 
41
 
 
42
 
sub new
43
 
 
44
 
    {
45
 
    my ($class, $controls, $options, $id, $validate_rules, $parentid) = @_ ;
46
 
    
47
 
    my $toplevel = $validate_rules?0:1 ;
48
 
    $id ||= 'topdiv' ;
49
 
    $options ||= {} ;    
50
 
    
51
 
    my $self = ref $class?$class:{} ;
52
 
    
53
 
    $self -> {controls}       = $controls ;
54
 
    $self -> {id}             = $id ;
55
 
    $self -> {parentid}       = $parentid ;
56
 
    $self -> {formname}       = $options -> {formname} || 'topform' ;
57
 
    $self -> {bottom_code}    = [] ;
58
 
    $self -> {validate_rules} = [] ;
59
 
    $self -> {toplevel}       = $toplevel ;
60
 
 
61
 
    bless $self, $class if (!ref $class);
62
 
    
63
 
    $forms{$id} = $self ;
64
 
    if (!$validate_rules)
65
 
        {
66
 
        $validate_rules = $self -> {validate_rules} = [] ;
67
 
        }
68
 
 
69
 
    $self -> new_controls ($controls, $options, undef, $id, $validate_rules, $options -> {masks}, $options -> {defaults}) ;
70
 
 
71
 
    $self -> {noframe} = 1 if ($controls && @$controls > 0 &&
72
 
                               $controls -> [0] -> noframe) ;
73
 
 
74
 
    
75
 
    if ($toplevel)
76
 
        {
77
 
        my $epf = $self -> {validate} = Embperl::Form::Validate -> new ($validate_rules, $self -> {formname}) if ($self -> {validate_rules}) ;
78
 
        $self -> add_code_at_bottom ($epf -> get_script_code) ;
79
 
        }
80
 
        
81
 
    return $self ;
82
 
    }
83
 
    
84
 
# ---------------------------------------------------------------------------
85
 
#
86
 
#   DESTROY
87
 
#
88
 
 
89
 
sub DESTROY
90
 
    {
91
 
    my ($self) = @_ ;
92
 
        
93
 
    delete $forms{$self->{id}} ;
94
 
    }
95
 
    
96
 
# ---------------------------------------------------------------------------
97
 
#
98
 
#   get_control_packages 
99
 
#
100
 
#   returns an array ref with packges where to search for controls
101
 
#
102
 
 
103
 
sub get_control_packages
104
 
    {
105
 
    my ($self) = @_ ;
106
 
    
107
 
    return $self -> {control_packages} || ['Embperl::Form::Control'] ;
108
 
    }
109
 
 
110
 
# ---------------------------------------------------------------------------
111
 
#
112
 
#   new_controls - transform elements to control objects
113
 
#
114
 
 
115
 
 
116
 
sub new_controls
117
 
 
118
 
    {
119
 
    my ($self, $controls, $options, $id, $formid, $validate_rules, $masks, $defaults) = @_ ;
120
 
    
121
 
    my $n = 0 ;
122
 
    my $packages = $self -> get_control_packages ;
123
 
    
124
 
    foreach my $control (@$controls)
125
 
        {
126
 
        my $name = $control -> {name} ;
127
 
        $control -> {type} =~ s/sf_select.+/select/ ;
128
 
        $control -> {parentid}   = $id if ($id) ;
129
 
        $control -> {id} ||= "$control->{name}-$n" ;
130
 
        $control -> {formid} = $formid ;
131
 
        
132
 
        my $type    = $control -> {type} ;
133
 
        my $default = $defaults -> {$name} || $defaults -> {"*$type"} || $defaults -> {'*'};
134
 
        my $mask    = $masks    -> {$name} || $masks -> {"*$type"} || $masks -> {'*'};
135
 
        if ($mask)
136
 
            {
137
 
            foreach (keys %$mask)
138
 
                {
139
 
                $control -> {$_} = $mask -> {$_}  ;   
140
 
                }
141
 
            }        
142
 
        if ($default)
143
 
            {
144
 
            foreach (keys %$default)
145
 
                {
146
 
                $control -> {$_} = $default -> {$_} if (!exists $control -> {$_}) ;   
147
 
                }
148
 
            }        
149
 
 
150
 
 
151
 
        if (ref $control eq 'HASH')
152
 
            {
153
 
            my $ctlmod ;
154
 
            my $type = $control -> {type} || ($control -> {name}?'input':'blank') ;
155
 
            if ($type =~ /::/) 
156
 
                {
157
 
                if (!defined (&{"$type\:\:new"}))
158
 
                    {
159
 
                    eval "require $type" ;
160
 
                    warn $@ if ($@) ; 
161
 
                    }
162
 
                $type -> new ($control) ;
163
 
                $ctlmod = $type ;
164
 
                }
165
 
            else
166
 
                {
167
 
                foreach my $package (@$packages)
168
 
                    {
169
 
                    my $mod = "$package\:\:$type"  ;
170
 
                    if ($mod -> can('new'))
171
 
                        {
172
 
                        $mod -> new ($control) ;
173
 
                        $ctlmod = $mod ;    
174
 
                        last ;
175
 
                        }
176
 
                    }
177
 
                if (!$ctlmod)
178
 
                    {    
179
 
                    foreach my $package (@$packages)
180
 
                        {
181
 
                        my $mod = "$package\:\:$type"  ;
182
 
                        eval "require $mod" ;
183
 
                        warn $@ if ($@) ; 
184
 
                        if ($mod -> can('new'))
185
 
                            {
186
 
                            $mod -> new ($control) ;
187
 
                            $ctlmod = $mod ;    
188
 
                            last ;
189
 
                            }
190
 
                        }
191
 
                    }    
192
 
                }
193
 
            die "No Module found for type = $type, searched: @$packages" if (!$ctlmod) ;
194
 
            }
195
 
 
196
 
        next if ($control -> is_disabled) ;
197
 
        push @{$validate_rules}, $control -> get_validate_rules ;
198
 
        if ($control -> {sublines})
199
 
            {
200
 
            my $i = 0 ;
201
 
            my $name = $control -> {name} ;
202
 
            foreach my $subcontrols (@{$control -> {sublines}})
203
 
                {
204
 
                next if (!$subcontrols) ;
205
 
                $self -> new_controls ($subcontrols, $options, "$name-$i", $formid, $validate_rules, $masks, $defaults) ;
206
 
                $i++ ;
207
 
                }
208
 
            }
209
 
        if ($control -> {subforms})
210
 
            {
211
 
            my @obj ;
212
 
            my @ids ;
213
 
            my $i = 1 ;
214
 
            
215
 
            foreach my $subcontrols (@{$control -> {subforms}})
216
 
                {
217
 
                next if (!$subcontrols) ;
218
 
                my $id = "$control->{name}-$i" ;
219
 
                my $class = ref $self ;
220
 
                my $subform = $class -> new ($subcontrols, $options, $id, $validate_rules, $self -> {id}) ;                
221
 
                push @ids, $id ;
222
 
                push @obj, $subform ; 
223
 
                $i++ ;
224
 
                }
225
 
            $control -> {subobjects} = \@obj ;
226
 
            $control -> {subids}     = \@ids ;
227
 
            }
228
 
        $n++ ;
229
 
        }
230
 
    }
231
 
 
232
 
# ---------------------------------------------------------------------------
233
 
#
234
 
#   parent_form - return parent form object if any
235
 
#
236
 
 
237
 
sub parent_form
238
 
    {
239
 
    my ($self) = @_ ;
240
 
 
241
 
    return $Embperl::Form::forms{$self -> {parentid}} ;
242
 
    }
243
 
 
244
 
    
245
 
# ---------------------------------------------------------------------------
246
 
#
247
 
#   add_code_at_bottom - add js code at the bottom of the page
248
 
#
249
 
 
250
 
sub add_code_at_bottom
251
 
 
252
 
    {
253
 
    my ($self, $code) = @_ ;
254
 
    
255
 
    push @{$self->{bottom_code}}, $code ;
256
 
    }
257
 
 
258
 
        
259
 
# ---------------------------------------------------------------------------
260
 
#
261
 
#   layout - build the layout of the form
262
 
#
263
 
 
264
 
sub layout
265
 
 
266
 
    {
267
 
    my ($self, $controls) = @_ ;
268
 
 
269
 
    $controls ||= $self -> {controls} ;
270
 
 
271
 
    my $x     = 0 ;
272
 
    my $max_x = 100 ;
273
 
    my $line  = [] ;
274
 
    my @lines ;
275
 
    my $max_num = 0 ;
276
 
    my $num = 0 ;
277
 
    foreach my $control (@$controls)
278
 
        {
279
 
        next if ($control -> is_disabled) ;
280
 
        my $width = $control -> {width_percent} || int($max_x / ($control -> {width} || 2)) ;
281
 
        if ($x + $width > $max_x || $control -> {newline} > 0 || (($control -> {sublines} || $control -> {subobjects}) && @$line))
282
 
            { # new line
283
 
            if ($x < $max_x)
284
 
                {
285
 
                push @$line, Embperl::Form::Control::blank -> new (
286
 
                        {width_percent => $max_x - $x }) ;
287
 
                }
288
 
            push @lines, $line ;
289
 
            $line = [] ;
290
 
            $x    = 0 ;
291
 
            $num  = 0 ;
292
 
            }
293
 
        push @$line, $control  ;
294
 
        $control -> {width_percent} = $width ;    
295
 
        $control -> {x_percent}     = $x ;    
296
 
        $x += $width ;
297
 
        $num++ ;
298
 
        $max_num = $num if ($num > $max_num) ;
299
 
 
300
 
        if ($control -> {subobjects} || $control -> {sublines} || $control -> {newline} < 0)
301
 
            { # new line
302
 
            if ($x < $max_x)
303
 
                {
304
 
                push @$line, Embperl::Form::Control::blank -> new (
305
 
                        {width_percent => $max_x - $x }) ;
306
 
                }
307
 
            push @lines, $line ;
308
 
            $line = [] ;
309
 
            $x    = 0 ;
310
 
            $num  = 0 ;
311
 
            }
312
 
 
313
 
        if ($control -> {sublines})
314
 
            {
315
 
            foreach my $subcontrols (@{$control -> {sublines}})
316
 
                {
317
 
                next if (!$subcontrols) ;
318
 
                my $sublines = $self -> layout ($subcontrols) ;
319
 
                push @lines, @$sublines ;
320
 
                }
321
 
            }
322
 
        if ($control -> {subobjects})
323
 
            {
324
 
            my @obj ;
325
 
            foreach my $subobj (@{$control -> {subobjects}})
326
 
                {
327
 
                next if (!$subobj) ;
328
 
                $subobj -> layout ;                
329
 
                }
330
 
            }
331
 
        }
332
 
        
333
 
    push @lines, $line if (@$line);
334
 
    $self -> {max_num} = $max_num ;    
335
 
    return $self -> {layout} = \@lines ;        
336
 
    }
337
 
 
338
 
    
339
 
# ---------------------------------------------------------------------------
340
 
#
341
 
#   show_controls - output the form control area
342
 
#
343
 
 
344
 
sub show_controls
345
 
 
346
 
    {
347
 
    my ($self, $data, $activeid) = @_ ;
348
 
 
349
 
    my $lines = $self -> {layout} ;
350
 
    my %n ;
351
 
    my $activesubid ;
352
 
    
353
 
    $self -> show_controls_begin ($activeid) ;
354
 
    my $lineno = 0 ;
355
 
    foreach my $line (@$lines)
356
 
        {
357
 
        my $lineid = @$line && $line->[0]{parentid}?"$line->[0]{parentid}":'id' ;
358
 
        $n{$lineid} ||= 10 ;
359
 
        
360
 
        $self -> show_line_begin ($lineno, "$lineid-$n{$lineid}", $activesubid);
361
 
        foreach my $control (@$line)
362
 
            {
363
 
            my $newactivesubid = $control -> get_active_id ;
364
 
            $control -> show ($data);
365
 
            $activesubid = $newactivesubid if ($newactivesubid) ;
366
 
            if ($control -> {subobjects})
367
 
                {
368
 
                my @obj ;
369
 
                $control -> show_sub_begin ;
370
 
                foreach my $subobj (@{$control -> {subobjects}})
371
 
                    {
372
 
                    next if (!$subobj || !$subobj -> {controls} || !@{$subobj -> {controls}}) ;
373
 
                    $subobj -> show ($data, $activesubid) ;
374
 
                    }
375
 
                $control -> show_sub_end ;
376
 
                }
377
 
            }
378
 
        $self -> show_line_end ($lineno);
379
 
        $lineno++ ;
380
 
        $n{$lineid}++ ;
381
 
        }
382
 
    $self -> show_controls_end ;
383
 
    
384
 
    return ;
385
 
    }
386
 
 
387
 
 
388
 
# ---------------------------------------------------------------------------
389
 
#
390
 
#   show - output the form 
391
 
#
392
 
 
393
 
sub show
394
 
 
395
 
    {
396
 
    my ($self, $data, $activeid) = @_ ;
397
 
 
398
 
    $self -> show_form_begin if ($self -> {toplevel});
399
 
    $self -> show_controls ($data, $activeid) ;
400
 
    $self -> show_form_end  if ($self -> {toplevel});
401
 
    }
402
 
    
403
 
    
404
 
# ---------------------------------------------------------------------------
405
 
#
406
 
#   validate - validate the form input
407
 
#
408
 
 
409
 
sub validate
410
 
 
411
 
    {
412
 
    
413
 
    }
414
 
 
415
 
 
416
 
#------------------------------------------------------------------------------------------
417
 
#
418
 
#   add_tabs
419
 
#
420
 
#   f�gt ein tab elsement mit subforms zu einem Formular hinzu
421
 
#
422
 
#   in $subform     array mit hashs 
423
 
#                       text => <anzeige text>
424
 
#                       fn   => Dateiname
425
 
#                       fields => Felddefinitionen (alternativ zu fn)
426
 
#
427
 
 
428
 
sub add_tabs
429
 
 
430
 
    {
431
 
    my ($self, $subforms, $args) = @_ ;
432
 
    my @forms ;
433
 
    my @values ;
434
 
    my @options ;
435
 
    my @grids;
436
 
    $args ||= {} ;
437
 
        
438
 
    foreach my $file (@$subforms)
439
 
        {
440
 
        my $fn        = $file -> {fn} ;
441
 
        my $subfields = $file -> {fields} ;  
442
 
        
443
 
        push @options, $file -> {text};      
444
 
        if ($fn)
445
 
            {
446
 
            my $obj = Execute ({object => "./$fn"} ) ;                           
447
 
            #$subfields = eval {$obj -> fields ($r, {%$file, %$args}) || undef};
448
 
            }
449
 
        push @forms,  $subfields;
450
 
        push @grids,  $file -> {grid};      
451
 
        push @values, $file -> {value} ||= scalar(@forms);
452
 
        }
453
 
 
454
 
    return { 
455
 
            section => 'cSectionText', 
456
 
            name    => '__auswahl', 
457
 
            type    => 'tabs',  
458
 
            values  => \@values, 
459
 
            grids   => \@grids,
460
 
            options => \@options, 
461
 
            subforms=> \@forms, 
462
 
            width   => 1,
463
 
            },
464
 
    }
465
 
 
466
 
#------------------------------------------------------------------------------------------
467
 
#
468
 
#   add_line
469
 
#
470
 
#   adds the given controls into one line
471
 
#
472
 
#
473
 
 
474
 
sub add_line
475
 
 
476
 
    {
477
 
    my ($self, $controls, $cnt) = @_ ;
478
 
 
479
 
    $cnt ||= @$controls ;        
480
 
    foreach my $control (@$controls)
481
 
        {
482
 
        $control -> {width} = $cnt ;
483
 
        }
484
 
 
485
 
    return @$controls ;
486
 
    }
487
 
 
488
 
#------------------------------------------------------------------------------------------
489
 
#
490
 
#   add_sublines
491
 
#
492
 
#   f�gt ein tab elsement mit subforms zu einem Formular hinzu
493
 
#
494
 
#   in $subform     array mit hashs 
495
 
#                       text => <anzeige text>
496
 
#                       fn   => Dateiname
497
 
#                       fields => Felddefinitionen (alternativ zu fn)
498
 
#
499
 
 
500
 
 
501
 
sub add_sublines
502
 
    {
503
 
    my ($self, $object_data, $subforms, $type) = @_; 
504
 
 
505
 
    my $name    = $object_data->{name};
506
 
    my $text    = $object_data->{text};
507
 
    my $width   = $object_data->{width};
508
 
    my $section = $object_data->{section};
509
 
    
510
 
    $text ||= $name;
511
 
 
512
 
    my @forms ;
513
 
    my @values ;
514
 
    my @options ;
515
 
        
516
 
    foreach my $file (@$subforms)
517
 
        {
518
 
        my $fn        = $file -> {fn} ;
519
 
        my $subfields = $file -> {fields} ;        
520
 
        if ($fn)
521
 
            {
522
 
            my $obj = Execute ({object => "./$fn"} ) ;         
523
 
            #$subfields = eval {$obj -> fields ($r,$file) || undef};
524
 
            }    
525
 
        push @forms,   $subfields || [];
526
 
        push @values,  $file->{value} || $file->{name};
527
 
        push @options, $file -> {text} || $file->{value} || $file->{name};
528
 
        }
529
 
 
530
 
    return { section => $section , width => $width, name => $name , text => $text, type => $type || 'select', 
531
 
             values => \@values, options => \@options, sublines => \@forms,
532
 
             class  => $object_data->{class}, controlclass  => $object_data->{controlclass}};
533
 
 
534
 
    }
535
 
    
536
 
#------------------------------------------------------------------------------------------
537
 
#
538
 
#   fields_add_checkbox_subform
539
 
#
540
 
#   f�gt ein checkbox Element mit Subforms hinzu 
541
 
#
542
 
#   in $subform     array mit hashs 
543
 
#                       text => <anzeige text>
544
 
#                       name => <name des Attributes>
545
 
#                       value => <Wert der checkbox>
546
 
#                       fn   => Dateiname
547
 
#                       fields => Felddefinitionen (alternativ zu fn)
548
 
#
549
 
 
550
 
sub add_checkbox_subform
551
 
    {
552
 
    my ($self, $subform, $args) = @_ ;
553
 
    $args ||= {} ;
554
 
 
555
 
    my $name    = $subform->{name};
556
 
    my $text    = $subform->{text};
557
 
    my $value   = $subform->{value} || 1 ;
558
 
 
559
 
    my $width   = $subform->{width};
560
 
    my $section;
561
 
    
562
 
    if(! $subform->{nosection})
563
 
        {
564
 
        $section = $subform->{section};
565
 
        $section ||= 1;
566
 
        }   
567
 
 
568
 
    $name   ||= "__$value";
569
 
    $width  ||= 1;
570
 
    
571
 
    my $subfield;
572
 
    my $fn;
573
 
    if($subfield = $subform->{fields})
574
 
        {
575
 
        # .... ok
576
 
        }
577
 
    elsif($fn = $subform->{fn})
578
 
        {
579
 
        my $obj = Execute ({object => "./$fn"} ) ;                         
580
 
        #$subfield = [eval {$obj -> fields ($r, { %$file, %$args} ) || undef}];
581
 
        }
582
 
 
583
 
 
584
 
    return  {type => 'checkbox' , section => $section, width => $width, name => $name, text => $text, value => $value, sublines => $subfield}   
585
 
           
586
 
    }
587
 
 
588
 
    
589
 
1;
590
 
    
591
 
 
592
 
__EMBPERL__
593
 
 
594
 
[$syntax EmbperlBlocks $]
595
 
 
596
 
[# ---------------------------------------------------------------------------
597
 
#
598
 
#   show_form_begin - output begin of form 
599
 
#]
600
 
 
601
 
[$ sub show_form_begin ($self) $]
602
 
<script language="javascript">var doValidate = 1 ;</script>
603
 
<script src="/js/EmbperlForm.js"></script>
604
 
<script src="/js/TableCtrl.js"></script>
605
 
 
606
 
<form id="[+ $self->{formname} +]" name="[+ $self->{formname} +]" method="post" action="[+ $self->{actionurl}+]"
607
 
[$ if ($self -> {on_submit_function}) $]
608
 
onSubmit="s=[+ $self->{on_submit_function} +];if (s) { v=doValidate; doValidate=1; return ((!v) || epform_validate_[+ $self->{formname} +]()); } else { return false; }"
609
 
[$else$]
610
 
onSubmit="v=doValidate; doValidate=1; return ( (!v) || epform_validate_[+ $self->{formname}+]());"
611
 
[$endif$]
612
 
>
613
 
[$endsub$]
614
 
 
615
 
[# ---------------------------------------------------------------------------
616
 
#
617
 
#   show_form_end - output end of form
618
 
#]
619
 
 
620
 
[$ sub show_form_end $]
621
 
</form>
622
 
[$endsub$]    
623
 
 
624
 
[ ---------------------------------------------------------------------------
625
 
#
626
 
#   show_controls_begin - output begin of form controls area
627
 
#]
628
 
 
629
 
[$ sub show_controls_begin  ($self, $activeid) 
630
 
 
631
 
my $parent = $self -> parent_form ;
632
 
my $class = $parent -> {noframe}?'cTableDivU':'cTableDiv' ;
633
 
$]
634
 
<div  id="[+ $self->{id} +]"
635
 
[$if ($activeid && $self->{id} ne $activeid) $] style="display: none" [$endif$]
636
 
>
637
 
[$if (!$self -> {noframe}) $]<table class="[+ $class +]"><tr><td class="cTabTD"> [$endif$]
638
 
<table class="cBase cTable">
639
 
[$endsub$]
640
 
    
641
 
[# ---------------------------------------------------------------------------
642
 
#
643
 
#   show_controls_end - output end of form controls area
644
 
#]
645
 
 
646
 
[$sub show_controls_end ($self) $]
647
 
</table>
648
 
[$ if (!$self -> {noframe}) $]</td></tr></table> [$endif$]
649
 
</div>
650
 
    
651
 
[$ if (@{$self->{bottom_code}}) $]
652
 
<script language="javascript">
653
 
[+ do { local $escmode = 0; join ("\n", @{$self->{bottom_code}}) } +]
654
 
</script>
655
 
[$endif$]
656
 
[$endsub$]
657
 
        
658
 
[# ---------------------------------------------------------------------------
659
 
#
660
 
#   show_line_begin - output begin of line
661
 
#]
662
 
 
663
 
[$ sub show_line_begin ($self, $lineno, $id, $activeid) 
664
 
    
665
 
    $id =~ /^(.+)-(\d+?)-(\d+?)$/ ;
666
 
    my $baseid = $1 ;
667
 
    my $baseidn = $2 ;
668
 
    $activeid =~ /^(.+)-(\d+?)$/ ;
669
 
    my $baseaid = $1 ;
670
 
    my $baseaidn = $2 ;
671
 
    
672
 
    my $class = $lineno == 0?'cTableRow1':'cTableRow' ;
673
 
$]    
674
 
    <tr class="[+ $class +]"
675
 
    [$if $id $] id="[+ $id +]"[$endif$]
676
 
    [$if ($baseid eq $baseaid && $baseidn != $baseaidn) $] style="display: none"[$endif$]
677
 
    >
678
 
[$endsub$]
679
 
    
680
 
[# ---------------------------------------------------------------------------
681
 
#
682
 
#   show_line_end - output end of line
683
 
#]
684
 
 
685
 
[$ sub show_line_end $]
686
 
  </tr>
687
 
[$endsub$]    
688
 
 
689
 
 
690
 
__END__
691
 
 
692
 
=pod
693
 
 
694
 
=head1 NAME
695
 
 
696
 
Embperl::Form - Embperl Form class
697
 
 
698
 
=head1 SYNOPSIS
699
 
 
700
 
=head1 DESCRIPTION
701
 
 
702
 
=head1 METHODS
703
 
 
704
 
=head2 new ($controls, $options)
705
 
 
706
 
=over 4
707
 
 
708
 
=item * $controls 
709
 
 
710
 
Array ref with controls which should be displayed
711
 
inside the form. Each control needs either to be a
712
 
hashref with all parameters for the control or
713
 
a control object.
714
 
 
715
 
If hash refs are given it's necessary to specify
716
 
the C<type> parameter, to let Embperl::Form
717
 
know which control to create.
718
 
 
719
 
See Embperl::Form::Control and Embperl::Form::Control::*
720
 
for a list of available parameters.
721
 
 
722
 
=item * $options
723
 
 
724
 
Hash ref which can take the following parameters:
725
 
 
726
 
=over 4
727
 
 
728
 
=item * formname
729
 
 
730
 
Will be used as name and id attribute of the form. If you have more
731
 
then one form on a page it's necessary to have different form names
732
 
to make form validation work correctly.
733
 
 
734
 
=item * masks
735
 
 
736
 
Contains a hash ref which can specify a set of masks
737
 
for the controls. A mask is a set of parameter which 
738
 
overwrite the setting of a control. You can specify
739
 
a mask for a control name (key is name), for a control 
740
 
type (key is *type) or for all controls (key is *).
741
 
 
742
 
Example:
743
 
 
744
 
    {
745
 
    'info'      => { readonly => 1},
746
 
    '*textarea' => { cols => 80 },
747
 
    '*'         => { labelclass => 'myclass', labelnowrap => 1}
748
 
    } 
749
 
    
750
 
This will force the control with the name C<info> to be readonly, it
751
 
will force all C<textarea> controls to have 80 columns and
752
 
it will force the label of all controls to have a class of myclass
753
 
and not to wrap the text.    
754
 
 
755
 
=item * defaults
756
 
 
757
 
Contains a hash ref which can specify a set of defaults
758
 
for the controls. You can specify
759
 
a default for a control name (key is name), for a control 
760
 
type (key is *type) or for all controls (key is *).
761
 
 
762
 
Example:
763
 
 
764
 
    {
765
 
    'info'      => { readonly => 1},
766
 
    '*textarea' => { cols => 80 },
767
 
    '*'         => { labelclass => 'myclass', labelnowrap => 1}
768
 
    } 
769
 
    
770
 
This will make the control with the name C<info> to default to be readonly, it
771
 
will deafult all C<textarea> controls to have 80 columns and
772
 
it will set the default class for the labels of all controls to
773
 
myclass and not to wrap the text.    
774
 
 
775
 
=back
776
 
 
777
 
=back
778
 
 
779
 
=head2 layout
780
 
 
781
 
=head2 show
782
 
 
783
 
 
784
 
=head1 AUTHOR
785
 
 
786
 
G. Richter (richter@dev.ecos.de)
787
 
 
788
 
=head1 SEE ALSO
789
 
 
790
 
perl(1), Embperl, Embperl::Form::Control
791
 
 
792
 
 
793
 
 
794
 
 
795
 
 
796
 
 
797
 
 
 
1
 
 
2
###################################################################################
 
3
#
 
4
#   Embperl - Copyright (c) 1997-2005 Gerald Richter / ecos gmbh   www.ecos.de
 
5
#
 
6
#   You may distribute under the terms of either the GNU General Public
 
7
#   License or the Artistic License, as specified in the Perl README file.
 
8
#
 
9
#   THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
 
10
#   IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
 
11
#   WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 
12
#
 
13
#   $Id$
 
14
#
 
15
###################################################################################
 
16
 
 
17
 
 
18
package Embperl::Form ;
 
19
 
 
20
use strict ;
 
21
 
 
22
use lib qw{..} ;
 
23
 
 
24
use Embperl ;
 
25
use Embperl::Form::Control ;
 
26
use Embperl::Form::Validate ;
 
27
use Embperl::Form::Control::blank ;
 
28
 
 
29
use Embperl::Inline ;
 
30
 
 
31
use Data::Dumper ;
 
32
 
 
33
our %forms ;
 
34
our %CLEANUP = ('forms' => 0) ;
 
35
 
 
36
# ---------------------------------------------------------------------------
 
37
#
 
38
#   new - create a new form
 
39
#
 
40
 
 
41
 
 
42
sub new
 
43
 
 
44
    {
 
45
    my ($class, $controls, $options, $id, $validate_rules, $parentptr) = @_ ;
 
46
 
 
47
    my $toplevel = $validate_rules?0:1 ;
 
48
    $id ||= 'topdiv' ;
 
49
    $options ||= {} ;
 
50
 
 
51
    my $self = ref $class?$class:{} ;
 
52
 
 
53
    $self -> {controls}       = $controls ;
 
54
    $self -> {options}        = $options ;
 
55
    $self -> {id}             = $id ;
 
56
    $self -> {parentptr}      = $parentptr ;
 
57
    $self -> {formname}       = $options -> {formname} || 'topform' ;
 
58
    $self -> {bottom_code}    = [] ;
 
59
    $self -> {validate_rules} = [] ;
 
60
    $self -> {toplevel}       = $toplevel ;
 
61
    $self -> {valign}         = $options -> {valign}   || 'top' ;
 
62
    $self -> {jsnamespace}    = $options -> {jsnamespace} || '' ;
 
63
    $self -> {jsnamespace}   .= '.' if ($self -> {jsnamespace}) ;
 
64
    
 
65
    bless $self, $class if (!ref $class);
 
66
 
 
67
    $Embperl::FormData::forms{"$self"} = $self ;
 
68
    if (!$validate_rules)
 
69
        {
 
70
        $validate_rules = $self -> {validate_rules} = [] ;
 
71
        }
 
72
 
 
73
    if ($toplevel)
 
74
        {
 
75
        $self -> {fields2empty} = [] ;
 
76
        $self -> {init_data}    = [] ;
 
77
        $self -> {prepare_fdat} = [] ;
 
78
        }
 
79
    else
 
80
        {
 
81
        $self -> {fields2empty} = $self -> parent_form -> {fields2empty} ;
 
82
        $self -> {init_data}    = $self -> parent_form -> {init_data} ;
 
83
        $self -> {prepare_fdat} = $self -> parent_form -> {prepare_fdat} ;
 
84
        }
 
85
 
 
86
    $self -> new_controls ($controls, $options, undef, $id, $validate_rules, $options -> {masks}, $options -> {defaults}) ;
 
87
 
 
88
    $self -> {noframe} = 1 if ($controls && @$controls > 0 &&
 
89
                               $controls -> [0] -> noframe) ;
 
90
 
 
91
 
 
92
    if ($toplevel)
 
93
        {
 
94
        my $epf = $self -> {validate} = Embperl::Form::Validate -> new ($validate_rules, $self -> {formname}) if ($self -> {validate_rules}) ;
 
95
        $self -> add_code_at_bottom ($epf -> get_script_code) ;
 
96
        }
 
97
 
 
98
    return $self ;
 
99
    }
 
100
 
 
101
# ---------------------------------------------------------------------------
 
102
#
 
103
#   DESTROY
 
104
#
 
105
 
 
106
sub DESTROY
 
107
    {
 
108
    my ($self) = @_ ;
 
109
 
 
110
    delete $Embperl::FormData::forms{"$self"} ;
 
111
    }
 
112
 
 
113
# ---------------------------------------------------------------------------
 
114
#
 
115
#   get_control_packages
 
116
#
 
117
#   returns an array ref with packges where to search for control classes
 
118
#
 
119
 
 
120
sub get_control_packages
 
121
    {
 
122
    my ($self) = @_ ;
 
123
 
 
124
    return $self -> {control_packages} || ['Embperl::Form::Control'] ;
 
125
    }
 
126
 
 
127
# ---------------------------------------------------------------------------
 
128
#
 
129
#   get_datasrc_packages
 
130
#
 
131
#   returns an array ref with packges where to search for data source classes
 
132
#
 
133
 
 
134
sub get_datasrc_packages
 
135
    {
 
136
    my ($self) = @_ ;
 
137
 
 
138
    return $self -> {datasrc_packages} || ['Embperl::Form::DataSource'] ;
 
139
    }
 
140
 
 
141
# ---------------------------------------------------------------------------
 
142
#
 
143
#   new_object - load a control or datasrc class and create a new object of
 
144
#                this class
 
145
#
 
146
#   in  $packages   arrayref of packages to search the class
 
147
#       $name       name of the class. Either a full package name or
 
148
#                   only the last part of the package. In the later
 
149
#                   @$packages are searched for this class
 
150
#   ret             reference to the object
 
151
#
 
152
 
 
153
sub new_object
 
154
 
 
155
    {
 
156
    my ($self, $packages, $name, $args) = @_ ;
 
157
 
 
158
    my $ctlmod ;
 
159
    my $obj ;
 
160
 
 
161
    $args ||= {} ;
 
162
 
 
163
    if ($name =~ /::/)
 
164
        {
 
165
        if (!defined (&{"$name\:\:new"}))
 
166
            {
 
167
            eval "require $name" ;
 
168
            warn $@ if ($@ && ($@ !~ /Can\'t locate/)) ;
 
169
            }
 
170
        $obj = $name -> new ($args) ;
 
171
        $ctlmod = $name ;
 
172
        }
 
173
    else
 
174
        {
 
175
        foreach my $package (@$packages)
 
176
            {
 
177
            my $mod = "$package\:\:$name"  ;
 
178
            if ($mod -> can('new'))
 
179
                {
 
180
                $obj = $mod -> new ($args) ;
 
181
                $ctlmod = $mod ;
 
182
                last ;
 
183
                }
 
184
            }
 
185
        if (!$ctlmod)
 
186
            {
 
187
            foreach my $package (@$packages)
 
188
                {
 
189
                my $mod = "$package\:\:$name"  ;
 
190
                eval "require $mod" ;
 
191
                warn $@ if ($@ && ($@ !~ /Can\'t locate/)) ;
 
192
                if ($mod -> can('new'))
 
193
                    {
 
194
                    $obj = $mod -> new ($args) ;
 
195
                    $ctlmod = $mod ;
 
196
                    last ;
 
197
                    }
 
198
                }
 
199
            }
 
200
        }
 
201
    die "No Module found for type = $name, searched: @$packages" if (!$ctlmod || !$obj) ;
 
202
 
 
203
    return $obj ;
 
204
    }
 
205
 
 
206
 
 
207
# ---------------------------------------------------------------------------
 
208
#
 
209
#   new_controls - transform elements to control objects
 
210
#
 
211
 
 
212
 
 
213
sub new_controls
 
214
 
 
215
    {
 
216
    my ($self, $controls, $options, $id, $formid, $validate_rules, $masks, $defaults) = @_ ;
 
217
 
 
218
    my $n = 0 ;
 
219
    my $packages = $self -> get_control_packages ;
 
220
 
 
221
    foreach my $control (@$controls)
 
222
        {
 
223
        die "control definition must be a hashref or an object, is '$control' " if (!ref $control || ref $control eq 'ARRAY');
 
224
 
 
225
        my $name = $control -> {name} ;
 
226
        $control -> {type} =~ s/sf_select.+/select/ ;
 
227
        $control -> {parentid}   = $id if ($id) ;
 
228
        $control -> {id} ||= "$control->{name}-$n" ;
 
229
        $control -> {formid} = $formid ;
 
230
        $control -> {formptr} = "$self" ;
 
231
 
 
232
        my $type    = $control -> {type} ;
 
233
        my $default = $defaults -> {$name} || $defaults -> {"*$type"} || $defaults -> {'*'};
 
234
        my $mask    = $masks    -> {$name} || $masks -> {"*$type"} || $masks -> {'*'};
 
235
        if ($mask)
 
236
            {
 
237
            foreach (keys %$mask)
 
238
                {
 
239
                $control -> {$_} = $mask -> {$_}  ;
 
240
                }
 
241
            }
 
242
        if ($default)
 
243
            {
 
244
            foreach (keys %$default)
 
245
                {
 
246
                $control -> {$_} = $default -> {$_} if (!exists $control -> {$_}) ;
 
247
                }
 
248
            }
 
249
 
 
250
 
 
251
        if (ref $control eq 'HASH')
 
252
            {
 
253
            my $type = $control -> {type} || ($control -> {name}?'input':'blank') ;
 
254
            $control = $self -> new_object ($packages, $type, $control) ;
 
255
            push @{$self -> {init_data}}, $control if ($control -> can ('init_data')) ;
 
256
            push @{$self -> {prepare_fdat}}, $control if ($control -> can ('prepare_fdat')) ;
 
257
 
 
258
            }
 
259
 
 
260
        next if ($control -> is_disabled) ;
 
261
        push @{$validate_rules}, $control -> get_validate_rules ;
 
262
        if ($control -> {sublines})
 
263
            {
 
264
            my $i = 0 ;
 
265
            my $name = $control -> {name} ;
 
266
            foreach my $subcontrols (@{$control -> {sublines}})
 
267
                {
 
268
                next if (!$subcontrols) ;
 
269
                $self -> new_controls ($subcontrols, $options, "$name-$i", $formid, $validate_rules, $masks, $defaults) ;
 
270
                $i++ ;
 
271
                }
 
272
            }
 
273
        if ($control -> {subforms})
 
274
            {
 
275
            my @obj ;
 
276
            my @ids ;
 
277
            my $i = 1 ;
 
278
 
 
279
            foreach my $subcontrols (@{$control -> {subforms}})
 
280
                {
 
281
                next if (!$subcontrols) ;
 
282
                my $id = "$control->{name}-$i" ;
 
283
                my $class = ref $self ;
 
284
                my $subform = $class -> new ($subcontrols, $options, $id, $validate_rules, "$self") ;
 
285
                push @ids, $id ;
 
286
                push @obj, $subform ;
 
287
                $i++ ;
 
288
                }
 
289
            $control -> {subobjects} = \@obj ;
 
290
            $control -> {subids}     = \@ids ;
 
291
            }
 
292
        $n++ ;
 
293
        }
 
294
    }
 
295
 
 
296
# ---------------------------------------------------------------------------
 
297
#
 
298
#   parent_form - return parent form object if any
 
299
#
 
300
 
 
301
sub parent_form
 
302
    {
 
303
    my ($self) = @_ ;
 
304
 
 
305
    return $Embperl::FormData::forms{$self -> {parentptr}} ;
 
306
    }
 
307
 
 
308
 
 
309
# ---------------------------------------------------------------------------
 
310
#
 
311
#   add_code_at_bottom - add js code at the bottom of the page
 
312
#
 
313
 
 
314
sub add_code_at_bottom
 
315
 
 
316
    {
 
317
    my ($self, $code) = @_ ;
 
318
 
 
319
    push @{$self->{bottom_code}}, $code ;
 
320
    }
 
321
 
 
322
 
 
323
# ---------------------------------------------------------------------------
 
324
#
 
325
#   layout - build the layout of the form
 
326
#
 
327
 
 
328
sub layout
 
329
 
 
330
    {
 
331
    my ($self, $controls, $level) = @_ ;
 
332
 
 
333
    $controls ||= $self -> {controls} ;
 
334
    $level    ||= 1 ;
 
335
 
 
336
    my $x     = 0 ;
 
337
    my $max_x = 100 ;
 
338
    my $line  = [] ;
 
339
    my @lines ;
 
340
    my $max_num = 0 ;
 
341
    my $num = 0 ;
 
342
    foreach my $control (@$controls)
 
343
        {
 
344
        next if ($control -> is_disabled) ;
 
345
        my $width = $control -> {width_percent} || int($max_x / ($control -> {width} || 2)) ;
 
346
        if ($x + $width > $max_x || $control -> {newline} > 0 || (($control -> {sublines} || $control -> {subobjects}) && @$line))
 
347
            { # new line
 
348
            if ($x < $max_x)
 
349
                {
 
350
                push @$line, Embperl::Form::Control::blank -> new (
 
351
                        {width_percent => $max_x - $x, level => $level }) ;
 
352
                }
 
353
            push @lines, $line ;
 
354
            $line = [] ;
 
355
            $x    = 0 ;
 
356
            $num  = 0 ;
 
357
            }
 
358
        push @$line, $control  ;
 
359
        $control -> {width_percent} = $width ;
 
360
        $control -> {x_percent}     = $x ;
 
361
        $control -> {level}         = $level ;
 
362
        $x += $width ;
 
363
        $num++ ;
 
364
        $max_num = $num if ($num > $max_num) ;
 
365
 
 
366
        if ($control -> {subobjects} || $control -> {sublines} || $control -> {newline} < 0)
 
367
            { # new line
 
368
            if ($x < $max_x)
 
369
                {
 
370
                push @$line, Embperl::Form::Control::blank -> new (
 
371
                        {width_percent => $max_x - $x }) ;
 
372
                }
 
373
            push @lines, $line ;
 
374
            $line = [] ;
 
375
            $x    = 0 ;
 
376
            $num  = 0 ;
 
377
            }
 
378
 
 
379
        if ($control -> {sublines})
 
380
            {
 
381
            foreach my $subcontrols (@{$control -> {sublines}})
 
382
                {
 
383
                next if (!$subcontrols) ;
 
384
                my $sublines = $self -> layout ($subcontrols, $level + 1) ;
 
385
                push @lines, @$sublines ;
 
386
                }
 
387
            }
 
388
        if ($control -> {subobjects})
 
389
            {
 
390
            my @obj ;
 
391
            foreach my $subobj (@{$control -> {subobjects}})
 
392
                {
 
393
                next if (!$subobj) ;
 
394
                $subobj -> layout ;
 
395
                }
 
396
            }
 
397
        }
 
398
 
 
399
    push @lines, $line if (@$line);
 
400
    $self -> {max_num} = $max_num ;
 
401
    return $self -> {layout} = \@lines ;
 
402
    }
 
403
 
 
404
 
 
405
# ---------------------------------------------------------------------------
 
406
#
 
407
#   show_controls - output the form control area
 
408
#
 
409
 
 
410
sub show_controls
 
411
 
 
412
    {
 
413
    my ($self, $req, $activeid) = @_ ;
 
414
 
 
415
    my $lines = $self -> {layout} ;
 
416
    my %n ;
 
417
    my $activesubid ;
 
418
    my @activesubid ;
 
419
 
 
420
    $self -> show_controls_begin ($req, $activeid) ;
 
421
    my $lineno = 0 ;
 
422
    foreach my $line (@$lines)
 
423
        {
 
424
        my $linelevel = @$line?$line->[0]{level}:0 ;
 
425
        my $lineid    = @$line && $line->[0]{parentid}?"$line->[0]{parentid}":'id' ;
 
426
        $n{$lineid} ||= 10 ;
 
427
 
 
428
        my $visible = $self -> show_line_begin ($req, $lineno, "$lineid-$n{$lineid}", $activesubid[$linelevel-1] || $activeid);
 
429
        foreach my $control (@$line)
 
430
            {
 
431
            my $newactivesubid = $visible?$control -> get_active_id ($req):'-' ;
 
432
            $control -> show ($req);
 
433
            $activesubid[$control -> {level}] = $newactivesubid if ($newactivesubid) ;
 
434
            if ($control -> {subobjects})
 
435
                {
 
436
                my @obj ;
 
437
                $control -> show_sub_begin ($req) ;
 
438
                foreach my $subobj (@{$control -> {subobjects}})
 
439
                    {
 
440
                    next if (!$subobj || !$subobj -> {controls} || !@{$subobj -> {controls}}) ;
 
441
                    $subobj -> show ($req, $activesubid[$control -> {level}]) ;
 
442
                    }
 
443
                $control -> show_sub_end ($req) ;
 
444
                }
 
445
            }
 
446
        $self -> show_line_end ($req, $lineno);
 
447
        $lineno++ ;
 
448
        $n{$lineid}++ ;
 
449
        }
 
450
    $self -> show_controls_end ($req) ;
 
451
 
 
452
    return ;
 
453
    }
 
454
 
 
455
 
 
456
# ---------------------------------------------------------------------------
 
457
#
 
458
#   show - output the form
 
459
#
 
460
 
 
461
sub show
 
462
 
 
463
    {
 
464
    my ($self, $req, $activeid) = @_ ;
 
465
 
 
466
    $self -> init_data ($req) if ($self -> {toplevel});
 
467
    #$self -> validate ($req) if ($self -> {toplevel});
 
468
    $self -> show_form_begin ($req) if ($self -> {toplevel});
 
469
    $self -> show_controls ($req, $activeid) ;
 
470
    $self -> show_form_end  ($req) if ($self -> {toplevel});
 
471
    }
 
472
 
 
473
 
 
474
# ---------------------------------------------------------------------------
 
475
#
 
476
#   init_data - init fdat before showing
 
477
#
 
478
 
 
479
sub init_data
 
480
 
 
481
    {
 
482
    my ($self, $req) = @_ ;
 
483
 
 
484
    foreach my $control (@{$self -> {init_data}})
 
485
        {
 
486
        $control -> init_data ($req) ;
 
487
        }
 
488
    }
 
489
 
 
490
# ---------------------------------------------------------------------------
 
491
#
 
492
#   prepare_fdat - change fdat after submit
 
493
#
 
494
 
 
495
sub prepare_fdat
 
496
 
 
497
    {
 
498
    my ($self, $req) = @_ ;
 
499
warn "embperl::form::prepare_fdat c=@{$self->{prepare_fdat}}" ;
 
500
    foreach my $control (@{$self -> {prepare_fdat}})
 
501
        {
 
502
        $control -> prepare_fdat ($req) ;
 
503
        }
 
504
    }
 
505
 
 
506
# ---------------------------------------------------------------------------
 
507
#
 
508
#   validate - validate the form input
 
509
#
 
510
 
 
511
sub validate
 
512
 
 
513
    {
 
514
 
 
515
    }
 
516
 
 
517
 
 
518
#------------------------------------------------------------------------------------------
 
519
#
 
520
#   add_tabs
 
521
#
 
522
#   f�gt ein tab elsement mit subforms zu einem Formular hinzu
 
523
#
 
524
#   in $subform     array mit hashs
 
525
#                       text => <anzeige text>
 
526
#                       fn   => Dateiname
 
527
#                       fields => Felddefinitionen (alternativ zu fn)
 
528
#
 
529
 
 
530
sub add_tabs
 
531
 
 
532
    {
 
533
    my ($self, $subforms, $args) = @_ ;
 
534
    my @forms ;
 
535
    my @values ;
 
536
    my @options ;
 
537
    my @grids;
 
538
    $args ||= {} ;
 
539
 
 
540
    foreach my $file (@$subforms)
 
541
        {
 
542
        my $fn        = $file -> {fn} ;
 
543
        my $subfields = $file -> {fields} ;
 
544
 
 
545
        push @options, $file -> {text};
 
546
        if ($fn)
 
547
            {
 
548
            my $obj = Execute ({object => "./$fn"} ) ;
 
549
            #$subfields = eval {$obj -> fields ($r, {%$file, %$args}) || undef};
 
550
            }
 
551
        push @forms,  $subfields;
 
552
        push @grids,  $file -> {grid};
 
553
        push @values, $file -> {value} ||= scalar(@forms);
 
554
        }
 
555
 
 
556
    return {
 
557
            section => 'cSectionText',
 
558
            name    => '__auswahl',
 
559
            type    => 'tabs',
 
560
            values  => \@values,
 
561
            grids   => \@grids,
 
562
            options => \@options,
 
563
            subforms=> \@forms,
 
564
            width   => 1,
 
565
            },
 
566
    }
 
567
 
 
568
#------------------------------------------------------------------------------------------
 
569
#
 
570
#   add_line
 
571
#
 
572
#   adds the given controls into one line
 
573
#
 
574
#
 
575
 
 
576
sub add_line
 
577
 
 
578
    {
 
579
    my ($self, $controls, $cnt) = @_ ;
 
580
 
 
581
    $cnt ||= @$controls ;
 
582
    foreach my $control (@$controls)
 
583
        {
 
584
        $control -> {width} = $cnt ;
 
585
        }
 
586
 
 
587
    return @$controls ;
 
588
    }
 
589
 
 
590
#------------------------------------------------------------------------------------------
 
591
#
 
592
#   add_sublines
 
593
#
 
594
#   f�gt ein tab elsement mit subforms zu einem Formular hinzu
 
595
#
 
596
#   in $subform     array mit hashs
 
597
#                       text => <anzeige text>
 
598
#                       fn   => Dateiname
 
599
#                       fields => Felddefinitionen (alternativ zu fn)
 
600
#
 
601
 
 
602
 
 
603
sub add_sublines
 
604
    {
 
605
    my ($self, $object_data, $subforms, $type) = @_;
 
606
 
 
607
    my $name    = $object_data->{name};
 
608
    my $text    = $object_data->{text};
 
609
    my $width   = $object_data->{width};
 
610
    my $section = $object_data->{section};
 
611
 
 
612
    $text ||= $name;
 
613
 
 
614
    my @forms ;
 
615
    my @values ;
 
616
    my @options ;
 
617
 
 
618
    foreach my $file (@$subforms)
 
619
        {
 
620
        my $fn        = $file -> {fn} ;
 
621
        my $subfields = $file -> {fields} ;
 
622
        if ($fn)
 
623
            {
 
624
            my $obj = Execute ({object => "./$fn"} ) ;
 
625
            #$subfields = eval {$obj -> fields ($r,$file) || undef};
 
626
            }
 
627
        push @forms,   $subfields || [];
 
628
        push @values,  $file->{value} || $file->{name};
 
629
        push @options, $file -> {text} || $file->{value} || $file->{name};
 
630
        }
 
631
 
 
632
    return { section => $section , width => $width, name => $name , text => $text, type => $type || 'select',
 
633
             values => \@values, options => \@options, sublines => \@forms,
 
634
             class  => $object_data->{class}, controlclass  => $object_data->{controlclass}};
 
635
 
 
636
    }
 
637
 
 
638
#------------------------------------------------------------------------------------------
 
639
#
 
640
#   fields_add_checkbox_subform
 
641
#
 
642
#   f�gt ein checkbox Element mit Subforms hinzu
 
643
#
 
644
#   in $subform     array mit hashs
 
645
#                       text => <anzeige text>
 
646
#                       name => <name des Attributes>
 
647
#                       value => <Wert der checkbox>
 
648
#                       fn   => Dateiname
 
649
#                       fields => Felddefinitionen (alternativ zu fn)
 
650
#
 
651
 
 
652
sub add_checkbox_subform
 
653
    {
 
654
    my ($self, $subform, $args) = @_ ;
 
655
    $args ||= {} ;
 
656
 
 
657
    my $name    = $subform->{name};
 
658
    my $text    = $subform->{text};
 
659
    my $value   = $subform->{value} || 1 ;
 
660
 
 
661
    my $width   = $subform->{width};
 
662
    my $section;
 
663
 
 
664
    if(! $subform->{nosection})
 
665
        {
 
666
        $section = $subform->{section};
 
667
        $section ||= 1;
 
668
        }
 
669
 
 
670
    $name   ||= "__$value";
 
671
    $width  ||= 1;
 
672
 
 
673
    my $subfield;
 
674
    my $fn;
 
675
    if($subfield = $subform->{fields})
 
676
        {
 
677
        # .... ok
 
678
        }
 
679
    elsif($fn = $subform->{fn})
 
680
        {
 
681
        my $obj = Execute ({object => "./$fn"} ) ;
 
682
        #$subfield = [eval {$obj -> fields ($r, { %$file, %$args} ) || undef}];
 
683
        }
 
684
 
 
685
 
 
686
    return  {type => 'checkbox' , section => $section, width => $width, name => $name, text => $text, value => $value, sublines => $subfield}
 
687
 
 
688
    }
 
689
 
 
690
 
 
691
1;
 
692
 
 
693
 
 
694
__EMBPERL__
 
695
 
 
696
[$syntax EmbperlBlocks $]
 
697
 
 
698
[# ---------------------------------------------------------------------------
 
699
#
 
700
#   show_form_begin - output begin of form
 
701
#]
 
702
 
 
703
[$ sub show_form_begin ($self, $req) $]
 
704
<script language="javascript">var doValidate = 1 ;</script>
 
705
<script src="/js/EmbperlForm.js"></script>
 
706
<script src="/js/TableCtrl.js"></script>
 
707
 
 
708
<form id="[+ $self->{formname} +]" name="[+ $self->{formname} +]" method="post" action="[+ $self->{actionurl}+]"
 
709
[$ if ($self -> {on_submit_function}) $]
 
710
onSubmit="s=[+ $self->{on_submit_function} +];if (s) { v=doValidate; doValidate=1; return ((!v) || epform_validate_[+ $self->{formname} +]()); } else { return false; }"
 
711
[$else$]
 
712
onSubmit="v=doValidate; doValidate=1; return ( (!v) || epform_validate_[+ $self->{formname}+]());"
 
713
[$endif$]
 
714
>
 
715
[$endsub$]
 
716
 
 
717
[# ---------------------------------------------------------------------------
 
718
#
 
719
#   show_form_end - output end of form
 
720
#]
 
721
 
 
722
[$ sub show_form_end ($req) $]
 
723
</form>
 
724
[$endsub$]
 
725
 
 
726
[ ---------------------------------------------------------------------------
 
727
#
 
728
#   show_controls_begin - output begin of form controls area
 
729
#]
 
730
 
 
731
[$ sub show_controls_begin  ($self, $req, $activeid)
 
732
 
 
733
my $parent = $self -> parent_form ;
 
734
my $class = $parent -> {noframe}?'cTableDivU':'cTableDiv' ;
 
735
$]
 
736
<div  id="[+ $self->{id} +]"
 
737
[$if ($activeid && $self->{id} ne $activeid) $] style="display: none" [$endif$]
 
738
>
 
739
[$if (!$self -> {noframe}) $]<table class="[+ $class +]"><tr><td class="cTabTD"> [$endif$]
 
740
<table class="cBase cTable">
 
741
[$endsub$]
 
742
 
 
743
[# ---------------------------------------------------------------------------
 
744
#
 
745
#   show_controls_end - output end of form controls area
 
746
#]
 
747
 
 
748
[$sub show_controls_end ($self, $req) $]
 
749
</table>
 
750
[$ if (!$self -> {noframe}) $]</td></tr></table> [$endif$]
 
751
</div>
 
752
 
 
753
[$ if (@{$self->{bottom_code}}) $]
 
754
<script language="javascript">
 
755
[+ do { local $escmode = 0; join ("\n", @{$self->{bottom_code}}) } +]
 
756
</script>
 
757
[$endif$]
 
758
[$ if ($self -> {toplevel} && @{$self -> {fields2empty}}) $]
 
759
<input type="hidden" name="-fields2empty" value="[+ join (' ', @{$self -> {fields2empty}}) +]">
 
760
[$endif$]
 
761
[$endsub$]
 
762
 
 
763
 
 
764
[# ---------------------------------------------------------------------------
 
765
#
 
766
#   show_line_begin - output begin of line
 
767
#]
 
768
 
 
769
[$ sub show_line_begin ($self, $req, $lineno, $id, $activeid)
 
770
 
 
771
    $id =~ /^(.+)-(\d+?)-(\d+?)$/ ;
 
772
    my $baseid = $1 ;
 
773
    my $baseidn = $2 ;
 
774
    $activeid =~ /^(.+)-(\d+?)$/ ;
 
775
    my $baseaid = $1 ;
 
776
    my $baseaidn = $2 ;
 
777
 
 
778
    my $class = $lineno == 0?'cTableRow1':'cTableRow' ;
 
779
$]
 
780
    <tr class="[+ $class +]" valign="[+ $self->{valign} +]"
 
781
    [$if $id $] id="[+ $id +]" [$endif$]
 
782
    [$if ($activeid eq '-' || ($baseid eq $baseaid && $baseidn != $baseaidn)) $] style="display: none" [$endif$]
 
783
    >
 
784
[* return !($activeid eq '-' || ($baseid eq $baseaid && $baseidn != $baseaidn)) *]
 
785
[$endsub$]
 
786
 
 
787
[# ---------------------------------------------------------------------------
 
788
#
 
789
#   show_line_end - output end of line
 
790
#]
 
791
 
 
792
[$ sub show_line_end ($req) $]
 
793
  </tr>
 
794
[$endsub$]
 
795
 
 
796
 
 
797
__END__
 
798
 
 
799
=pod
 
800
 
 
801
=head1 NAME
 
802
 
 
803
Embperl::Form - Embperl Form class
 
804
 
 
805
=head1 SYNOPSIS
 
806
 
 
807
=head1 DESCRIPTION
 
808
 
 
809
=head1 METHODS
 
810
 
 
811
=head2 new ($controls, $options)
 
812
 
 
813
=over 4
 
814
 
 
815
=item * $controls
 
816
 
 
817
Array ref with controls which should be displayed
 
818
inside the form. Each control needs either to be a
 
819
hashref with all parameters for the control or
 
820
a control object.
 
821
 
 
822
If hash refs are given it's necessary to specify
 
823
the C<type> parameter, to let Embperl::Form
 
824
know which control to create.
 
825
 
 
826
See Embperl::Form::Control and Embperl::Form::Control::*
 
827
for a list of available parameters.
 
828
 
 
829
=item * $options
 
830
 
 
831
Hash ref which can take the following parameters:
 
832
 
 
833
=over 4
 
834
 
 
835
=item * formname
 
836
 
 
837
Will be used as name and id attribute of the form. If you have more
 
838
then one form on a page it's necessary to have different form names
 
839
to make form validation work correctly.
 
840
 
 
841
=item * masks
 
842
 
 
843
Contains a hash ref which can specify a set of masks
 
844
for the controls. A mask is a set of parameter which
 
845
overwrite the setting of a control. You can specify
 
846
a mask for a control name (key is name), for a control
 
847
type (key is *type) or for all controls (key is *).
 
848
 
 
849
Example:
 
850
 
 
851
    {
 
852
    'info'      => { readonly => 1},
 
853
    '*textarea' => { cols => 80 },
 
854
    '*'         => { labelclass => 'myclass', labelnowrap => 1}
 
855
    }
 
856
 
 
857
This will force the control with the name C<info> to be readonly, it
 
858
will force all C<textarea> controls to have 80 columns and
 
859
it will force the label of all controls to have a class of myclass
 
860
and not to wrap the text.
 
861
 
 
862
=item * defaults
 
863
 
 
864
Contains a hash ref which can specify a set of defaults
 
865
for the controls. You can specify
 
866
a default for a control name (key is name), for a control
 
867
type (key is *type) or for all controls (key is *).
 
868
 
 
869
Example:
 
870
 
 
871
    {
 
872
    'info'      => { readonly => 1},
 
873
    '*textarea' => { cols => 80 },
 
874
    '*'         => { labelclass => 'myclass', labelnowrap => 1}
 
875
    }
 
876
 
 
877
This will make the control with the name C<info> to default to be readonly, it
 
878
will deafult all C<textarea> controls to have 80 columns and
 
879
it will set the default class for the labels of all controls to
 
880
myclass and not to wrap the text.
 
881
 
 
882
=item * valign
 
883
 
 
884
valign for control cells. Defaults to 'top' .
 
885
 
 
886
=item * jsnamespace
 
887
 
 
888
Give the JavaScript Namespace. This allows to load js Files in
 
889
a top frame or different frame, which will speed up page loading,
 
890
because the browser does not need to reload the js code on every load.
 
891
 
 
892
Example:
 
893
 
 
894
    jsnamespace => 'top'
 
895
 
 
896
=back
 
897
 
 
898
=back
 
899
 
 
900
=head2 layout
 
901
 
 
902
=head2 show
 
903
 
 
904
 
 
905
=head1 AUTHOR
 
906
 
 
907
G. Richter (richter@dev.ecos.de)
 
908
 
 
909
=head1 SEE ALSO
 
910
 
 
911
perl(1), Embperl, Embperl::Form::Control
 
912
 
 
913
 
 
914
 
 
915
 
 
916