view release on metacpan or  search on metacpan

lib/CGI/FormBuilder.pm  view on Meta::CPAN

    return $f->value;
}

sub new_field {
    my $self = shift;
    my $args = arghash(@_);
    puke "Need a name for \$form->new_field()" unless exists $args->{name};
    debug 1, "called \$form->new_field($args->{name})";

    # extract our per-field options from rearrange
    while (my($from,$to) = each %REARRANGE) {
        next unless exists  $self->{$from};
        next if     defined $args->{$to};     # manually set
        my $tval = rearrange($self->{$from}, $args->{name});
        debug 2, "rearrange: \$args->{$to} = $tval;";
        $args->{$to} = $tval;
    }

    $args->{type} = lc $self->{fieldtype}
        if $self->{fieldtype} && ! exists $args->{type};
    if ($self->{fieldattr}) {   # legacy
        while (my($k,$v) = each %{$self->{fieldattr}}) {
            next if exists $args->{$k};
            $args->{$k} = $v;
        }
    }
    
    my $f = CGI::FormBuilder::Field->new($self, $args);
    debug 1, "created field $f";
    return $f;   # already set args above ^^^
}

*fieldset = \&fieldsets;
sub fieldsets {
    my $self = shift;
    if (@_) {
        if (ref($_[0]) eq 'ARRAY') {
            $self->{fieldsets} = shift;
        } elsif (@_ % 2) {
            # search for fieldset and update it, or add it
            # can't use optalign because must change in-place
            while (@_) {
                my($k,$v) = (shift,shift);
                for (@{$self->{fieldsets}||=[]}) {
                    if ($k eq $_->[0]) {
                        $_->[1] = $v;
                        undef $k;   # catch below
                    }
                }
                # not found, so append
                if ($k) {
                    push @{$self->{fieldsets}}, [$k,$v];
                }
            }
        } else {
            puke "Invalid usage of \$form->fieldsets(name => 'Label')"
        }
    }

    # We look for all the fieldset definitions, checking the main
    # form for a "proper" legend ala our other settings. We then
    # divide up all the fields and group them in fieldsets.
    my(%legends, @sets);
    for (optalign($self->{fieldsets})) {
        my($o,$n) = optval($_);
        next if exists $legends{$o};
        push @sets, $o;
        debug 2, "added fieldset $o (legend=$n) to \@sets";
        $legends{$o} = $n;
    }

    # find *all* our fieldsets, even hidden in fields w/o Human Tags
    for ($self->field) {
        next unless my $o = $_->fieldset;
        next if exists $legends{$o};
        push @sets, $o;
        debug 2, "added fieldset $o (legend=undef) to \@sets";
        $legends{$o} = $o;  # use fieldset as <legend>
    }
    return wantarray ? @sets : \%legends;
}

sub fieldlist {
    my $self = shift;
    my @fields = @_ ? @_ : $self->field;
    my(%saw, @ret);
    for my $set ($self->fieldsets) {
        # reorder fields
        for (@fields) {
            next if $saw{$_};
            if ($_->fieldset && $_->fieldset eq $set) {
                # if this field is in this fieldset, regroup
                push @ret, $_;
                debug 2, "added field $_ to field order (fieldset=$set)";
                $saw{$_} = 1;
            }
        }
    }

    # keep non-fieldset fields in order relative
    # to one another, appending them to the end
    # of the form
    for (@fields) {
        debug 2, "appended non-fieldset field $_ to form";
        push @ret, $_ unless $saw{$_};
    }

    return wantarray ? @ret : \@ret;
}

sub header {
    my $self = shift;
    $self->{header} = shift if @_;
    return unless $self->{header};
    my %head;
    if ($self->{cookies} && defined(my $sid = $self->sessionid)) {
        require CGI::Cookie;
        $head{'-cookie'} = CGI::Cookie->new(-name  => $self->{sessionidname},
                                            -value => $sid);
    }
    # Set the charset for i18n
    $head{'-charset'} = $self->charset;

    # Forcibly require - no extra time in normal case, and if 
    # using Apache::Request this needs to be loaded anyways.
    return "Content-type: text/html\n\n" if $::TESTING;
    require CGI;
    return  CGI::header(%head);    # CGI.pm MOD_PERL fanciness
}

sub charset {
    my $self = shift;
    $self->{charset} = shift if @_;
    return $self->{charset} || $self->{messages}->charset || 'iso8859-1';
}

sub lang {
    my $self = shift;
    $self->{lang} = shift if @_;
    return $self->{lang} || $self->{messages}->lang || 'en_US';