Cook results from the CPAN

CGI-FormBuilder

        }
    }

    # 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';
}

sub dtd {
    my $self = shift;
    $self->{dtd} = shift if @_;
    return '<html>' if $::TESTING;

    # replace special chars in dtd by exec'ing subs
    my $dtd = $self->{dtd};
    $dtd =~ s/\{(\w+)\}/$self->$1/ge;
    return $dtd;
}

sub title {
    my $self = shift;
    $self->{title} = shift if @_;
    return $self->{title} if exists $self->{title};
    return toname(basename);
}

*script_name = \&action;
sub action {
    local $^W = 0;  # -w sucks (still)
    my $self = shift;
    $self->{action} = shift if @_;
    return $self->{action} if exists $self->{action};
    return basename . $ENV{PATH_INFO};
}

sub font {
    my $self = shift;
    $self->{font} = shift if @_;
    return '' unless $self->{font};
    return '' if $self->{stylesheet};   # kill fonts for style

    # Catch for allowable hashref or string
    my $ret;
    my $ref = ref $self->{font} || '';

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

    my $self = shift;

    # single hashref kills everything; a list is temporary
    $self->{div} = shift if @_ == 1 && UNIVERSAL::isa($_[0], 'HASH');

    my $attr = $self->{div};
    if (@_) {
        # if still have args, create a temp hash
        my %temp = %$attr;
        while (my $k = shift) {
            $temp{$k} = shift;
        }
        $attr = \%temp;
    }

    return htmltag('div', $attr);
}

sub submitted {
    my $self = shift;
    my $smnam = shift || $self->submittedname;  # temp smnam
    my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam;

    if ($self->{params}->param($smtag)) {
        # If we've been submitted, then we return the value of
        # the submit tag (which allows multiple submission buttons).
        # Must use an "|| 0E0" or else hitting "Enter" won't cause
        # $form->submitted to be true (as the button is only sent
        # across CGI when clicked).
        my $sr = $self->{params}->param($self->submitname) || '0E0';
        debug 2, "\$form->submitted() is true, returning $sr";
        return $sr;
    }
    return 0;
}

# This creates a modified self_url, just including fields (no sessionid, etc)
sub query_string {
    my $self = shift;
    my @qstr = ();
    for my $f ($self->fields, $self->keepextras) {
        # get all values, but ONLY from CGI
        push @qstr, join('=', escapeurl($f), escapeurl($_)) for $self->cgi_param($f);
    }
    return join '&', @qstr;
}

sub self_url {
    my $self = shift;
    return join '?', $self->action, $self->query_string;
}

# must forcibly return scalar undef for CGI::Session easiness
sub sessionid {
    my $self = shift;
    $self->{sessionid} = shift if @_;
    return $self->{sessionid} if $self->{sessionid};
    return undef unless $self->{sessionidname};
    my %cookies;
    if ($self->{cookies}) {
        require CGI::Cookie;
        %cookies = CGI::Cookie->fetch;
    }
    if (my $cook = $cookies{"$self->{sessionidname}"}) {
        return $cook->value;
    } else {
        return $self->{params}->param($self->{sessionidname}) || undef;
    }
}

sub statetags {
    my $self = shift;
    my @html = ();

    # get _submitted
    my $smnam = $self->submittedname;
    my $smtag = $self->{name} ? "${smnam}_$self->{name}" : $smnam;
    my $smval = $self->{params}->param($smnam) + 1;
    push @html, htmltag('input', name => $smtag, value => $smval, type => 'hidden');

    # and how about _sessionid
    if (defined(my $sid = $self->sessionid)) {
        push @html, htmltag('input', name => $self->{sessionidname},
                                     type => 'hidden', value => $sid);
    }

    # and what page (hooks for ::Multi)
    if (defined $self->{page}) {
        push @html, htmltag('input', name => $self->pagename,
                                     type => 'hidden', value => $self->{page});
    }

    return wantarray ? @html : join "\n", @html;
}

*keepextra = \&keepextras;
sub keepextras {
    local $^W = 0;      # -w sucks
    my $self  = shift;
    my @keep  = ();
    my @html  = ();

    # which ones do they want?
    $self->{keepextras} = shift if @_;
    return '' unless $self->{keepextras};

    # If we set keepextras, then this means that any extra fields that
    # we've set that are *not* in our fields() will be added to the form
    my $ref = ref $self->{keepextras} || '';
    if ($ref eq 'ARRAY') {
        @keep = @{$self->{keepextras}};
    } elsif ($ref) {
        puke "Unsupported data structure type '$ref' passed to 'keepextras' option";
    } else {
        # Set to "1", so must go thru all params, skipping 
        # leading underscore fields and form fields
        for my $p ($self->{params}->param()) {
            next if $p =~ /^_/  || $self->{fieldrefs}{$p};
            push @keep, $p;
        }
    }

( run in 1.311 second using v1.01-cache-2.11-cpan-22024b96cdf )