view release on metacpan or  search on metacpan

Embperl/Form.pm  view on Meta::CPAN

###################################################################################
#
#   Embperl - Copyright (c) 1997-2008 Gerald Richter / ecos gmbh  www.ecos.de
#   Embperl - Copyright (c) 2008-2015 Gerald Richter
#   Embperl - Copyright (c) 2015-2023 actevy.io
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file.
#
#   THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
#   IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
#   WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
###################################################################################


package Embperl::Form ;

use strict ;

use lib qw{..} ;

use Embperl ;
use Embperl::Form::Control ;
use Embperl::Form::Validate ;
use Embperl::Form::Control::blank ;

use Embperl::Inline ;

use Data::Dumper ;
use Storable ;
use MIME::Base64 ;
use Scalar::Util qw{weaken} ;

our %forms ;
our $form_cnt = 1 ;
our %CLEANUP = ('forms' => 0) ;

use vars qw{$epreq} ;

# ---------------------------------------------------------------------------
#
#   sub_new - create a new sub form
#


sub sub_new

    {
    my ($class, $controls, $options, $id, $toplevel, $parentptr) = @_ ;

    $id ||= 'topdiv' ;
    $options ||= {} ;
    $toplevel = 1 if (!defined ($toplevel)) ;

    my $self = ref $class?$class:{} ;

    $self -> {controls}       = $controls ;
    $self -> {options}        = $options ;
    $self -> {id}             = $id ;
    $self -> {parentptr}      = $parentptr ;
    $self -> {formname}       = $options -> {formname} || 'topform' ;
    $self -> {bottom_code}    = [] ;
    $self -> {validate_rules} = [] ;
    $self -> {toplevel}       = $toplevel ;
    $self -> {checkitems}     = $options -> {checkitems} ;
    $self -> {valign}         = $options -> {valign}   || 'top' ;
    $self -> {jsnamespace}    = $options -> {jsnamespace} || '' ;
    $self -> {jsnamespace}   .= '.' if ($self -> {jsnamespace}) ;
    $self -> {disable}        = $options -> {disable} ;
    $self -> {control_packages} = $options -> {control_packages} ;
    $self -> {datasrc_packages} = $options -> {datasrc_packages} ;
    $self -> {formptr}          = ($options -> {formptr} || "$self") . '/' . $id  ;
    bless $self, $class if (!ref $class);

    # The following lines needs to there twice!
    # some weired bug in Perl?
    $Embperl::FormData::forms{$self -> {formptr}} = $self ;
    weaken($Embperl::FormData::forms{$self -> {formptr}});
    #$Embperl::FormData::forms{$self -> {formptr}} = $self ;

    if ($toplevel)
        {
        $self -> {fields2empty} = [] ;
        $self -> {init_data}    = [] ;
        $self -> {init_markup}  = [] ;
        $self -> {prepare_fdat} = [] ;
        $self -> {code_refs}    = [] ;
        $self -> {constrain_attrs} = [] ;
        $self -> {do_validate}  = [] ;
        $self -> {all_controls}  = {} ;
        }
    else
        {
        $self -> {fields2empty} = $self -> parent_form -> {fields2empty} ;
        $self -> {init_data}    = $self -> parent_form -> {init_data} ;
        $self -> {init_markup}  = $self -> parent_form -> {init_markup} ;
        $self -> {prepare_fdat} = $self -> parent_form -> {prepare_fdat} ;
        $self -> {constrain_attrs}    = $self -> parent_form -> {constrain_attrs} ;
        $self -> {code_refs}    = $self -> parent_form -> {code_refs} ;
        $self -> {do_validate}  = $self -> parent_form -> {do_validate} ;
        $self -> {all_controls} = $self -> parent_form -> {all_controls} ;
        }
    if ($self -> has_code_refs)
        {
        push @{$self -> {code_refs}}, $self  ;
        weaken ($self -> {code_refs}[-1]) ;
        }
    $self -> new_controls ($controls, $options, undef, $id, $options -> {masks}, $options -> {defaults}) ;

    $self -> {noframe} = 1 if ($controls && @$controls > 0 &&
                               $controls -> [0] -> noframe) ;


    return $self ;
    }

# ---------------------------------------------------------------------------
#
#   new - create a new form
#

sub new
    {
    my $class = shift ;
    return $class -> sub_new (@_) ;
    }

# ---------------------------------------------------------------------------
#
#   clone - clone an existing form. trivial new here, maybe more complex for kids
#       This will always return a Embperl::Form, no matter what $self is

sub cloned_form
    {
    my $self  = shift ;
    return Embperl::Form -> sub_new (@_) ;
    }

# ---------------------------------------------------------------------------
#
#   DESTROY
#

sub DESTROY
    {
    my ($self) = @_ ;

    delete $Embperl::FormData::forms{$self -> {formptr}} ;
    }

# ---------------------------------------------------------------------------
#
#   get_control_packages
#
#   returns an array ref with packges where to search for control classes
#

sub get_control_packages
    {
    my ($self) = @_ ;

    return $self -> {control_packages} || ['Embperl::Form::Control'] ;
    }

# ---------------------------------------------------------------------------
#

Embperl/Form.pm  view on Meta::CPAN

#


sub new_controls

    {
    my ($self, $controls, $options, $id, $formid, $masks, $defaults, $no_init) = @_ ;

    my $n = 0 ;
    my $packages = $self -> get_control_packages ;

    foreach my $control (@$controls)
        {
        die "control definition must be a hashref or an object, is '$control' " if (!ref $control || ref $control eq 'ARRAY');

        my $ctlid = $control->{name} ;
        my $q  = 2 ;
        while (exists $self -> {controlids}{$ctlid})
            {
            $ctlid = $control->{name} . '_' . $q ;
            $q++ ;
            }

        my $name = $control -> {name} ;
        $control -> {type}      =~ s/sf_select.+/select/ ;
        $control -> {type}      ||= ($control -> {name}?'input':'blank') ;
        $control -> {parentid}  = $id if ($id) ;
        $control -> {id}      ||= $ctlid ;
        $control -> {basename}||= $control->{name} ;
        $control -> {formid}    = $formid ;
        $control -> {formptr}   = $self -> {formptr}  ;

        my $type    = $control -> {type} ;
        my $default = $defaults -> {$name} || $defaults -> {"*$type"} || $defaults -> {'*'};
        my $mask    = $masks    -> {$name} || $masks -> {"*$type"} || $masks -> {'*'};

        if ($mask)
            {
            foreach (keys %$mask)
                {
                $control -> {$_} = $mask -> {$_}  ;
                }
            }
        if ($default)
            {
            foreach (keys %$default)
                {
                $control -> {$_} = $default -> {$_} if (!exists $control -> {$_}) ;
                }
            }

        if (ref $control eq 'HASH')
            {
            my $type = $control -> {type}  ;
            $control = $self -> new_object ($packages, $type, $control) ;
            if (!$no_init)
                {
                if ($control -> can ('init_data'))
                    {
                    push @{$self -> {init_data}}, $control ;
                    weaken ($self -> {init_data}[-1]) ;
                    }
                if ($control -> can ('init_markup'))
                    {
                    push @{$self -> {init_markup}}, $control ;
                    weaken ($self -> {init_markup}[-1]) ;
                    }
                if ($control -> can ('prepare_fdat'))
                    {
                    push @{$self -> {prepare_fdat}}, $control ;
                    weaken ($self -> {prepare_fdat}[-1]) ;
                    }
                if ($control -> has_code_refs)
                    {
                    push @{$self -> {code_refs}}, $control ;
                    weaken ($self -> {code_refs}[-1]) ;
                    }
                if ($control -> has_validate_rules)
                    {
                    push @{$self -> {do_validate}}, $control ;
                    weaken ($self -> {do_validate}[-1]) ;
                    }
                push @{$self -> {constrain_attrs}}, $control -> constrain_attrs ;
                $self -> {all_controls}{$name} = $control ;
                weaken ($self -> {all_controls}{$name}) ;
                }
            }
        $self -> {controlids}{$control->{id}} = $control ;

        next if ($control -> is_disabled ()) ;
        if ($control -> {sublines})
            {
            my $i = 0 ;
            my $name = $control -> {name} ;
            foreach my $subcontrols (@{$control -> {sublines}})
                {
                next if (!$subcontrols) ;
                $self -> new_controls ($subcontrols, $options, "$name-$i", $formid, $masks, $defaults, $no_init) ;
                $i++ ;
                }
            }
        if ($control -> {subforms})
            {
            my @obj ;
            my @ids ;
            my $i = 0 ;

            foreach my $subcontrols (@{$control -> {subforms}})
                {
                next if (!$subcontrols) ;
                my $ctlid = $control -> {values}[$i] || $control->{name} ;
                my $q  = 2 ;
                while (exists $self -> {controlids}{$ctlid})
                    {
                    $ctlid = $control->{name} . '_' . $q ;
                    $q++ ;
                    }
                my $class = ref $self ;
                local $options -> {disable} = $control -> {disables}[$i] ;
                my $subform = $class -> sub_new ($subcontrols, $options, $ctlid, 0, $self -> {formptr}) ;
                $subform -> {text} ||= $control -> {options}[$i] if (exists ($control -> {options}) && $control -> {options}[$i]) ;
                $subform -> {parent_control} = $control ;
                weaken ($subform -> {parent_control}) ;
                push @ids, $ctlid ;
                push @obj, $subform ;
                $i++ ;
                }
            $control -> {subobjects} = \@obj ;
            $control -> {subids}     = \@ids ;
            }
        $n++ ;
        }
    }

# ---------------------------------------------------------------------------
#
#   parent_form - return parent form object if any
#

sub parent_form
    {
    my ($self) = @_ ;

    return $Embperl::FormData::forms{$self -> {parentptr}} ;
    }



# ---------------------------------------------------------------------------
#
#   add_code_at_bottom - add js code at the bottom of the page
#

sub add_code_at_bottom

    {
    my ($self, $code) = @_ ;

    push @{$self->{bottom_code}}, $code ;
    }


# ---------------------------------------------------------------------------
#
#   layout - build the layout of the form
#

sub layout

    {
    my ($self, $controls, $level) = @_ ;

    $controls ||= $self -> {controls} ;
    $level    ||= 1 ;

    my $hidden = $self -> {hidden} ||= [] ;

    my $x     = 0 ;
    my $max_x = 100 ;
    my $line  = [] ;
    my @lines ;
    my $max_num = 0 ;
    my $num = 0 ;