view release on metacpan or  search on metacpan

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

                $line = $term;
                $term = $lterm;
            }
        } else {
            # count leading space if it's there
            $s = 1;     # reset
            $s += length($1) if $term =~ s/^(\s+)//;
            $line =~ s/\s+$//;       # trailing space

            # uplevel pre-check (may have a value below)
            if ($s == 1) {
                $ptr = $ret;
                @lvl = ();
                $lsp = 1;       # set to zero for next pass
                $refield = 0;
                $inval = 0;
            } elsif ($s <= $lsp) {
                $ptr = pop(@lvl) || $ret;
                $lsp = $s;      # uplevel term indent
                $inval = 0;
            }

            # special catch for continued (indented) line
            if ($s >= $psp && $inval && ! length $line) {
                $line = $term;
                $term = $lterm;
            }
            debug 2, "[$s >= $psp, inval=$inval] term=$term; line=$line";
        }
        $psp = $s;

        # has a value
        if (length $line) {
            debug 2, "$term = $line ($s < $lsp)";

            $lsp ||= $s;    # first valid term indent

            # <<HERE strings bypass all subsequent parsing
            if ($line =~ /^<<(.+)/) {
                $lterm = $term;
                $here  = $1;
                next;
            } elsif ($here) {
                $ptr->{$term} .= "$line\n";
                next;
            }

            my @val;
            if ($term =~ /^js/ || $term =~ /^on[a-z]/ || $term eq 'messages' || $term eq 'comment') {
                @val = $line;   # verbatim
            } elsif ($line =~ s/^\\(.)//) {
                # Reference - this is tricky. Go all the way up to
                # the top to make sure, or use $self->{caller} if
                # we were given a place to go.
                my $r = $1;
                my $l = 0;
                my @p;
                if ($self->{caller}) {
                    @p = $self->{caller};
                } else {
                    while (my $pkg = caller($l++)) {
                        push @p, $pkg;
                    }
                }
                $line = "$r$p[-1]\::$line" unless $line =~ /::/;
                debug 2, qq{eval "\@val = (\\$line)"};
                eval "\@val = (\\$line)";
                belch "Loading $line failed: $@" if $@;
            } else {
                # split commas
                @val = split /\s*,\s*/, $line;

                # m=Male, f=Female -> [m,Male], [f,Female]
                for (my $i=0; $i < @val; $i++) {
                    $val[$i] = [ split /\s*=\s*/, $val[$i], 2 ] if $val[$i] =~ /=/;
                }
            }

            # only arrayref on multi values b/c FB is "smart"
            if ($ptr->{$term}) {
                $ptr->{$term} = (ref $ptr->{$term})
                                    ? [ @{$ptr->{$term}}, @val ] : @val > 1 ? \@val :
                                      ref($val[0]) eq 'ARRAY' ? \@val : $val[0];
            } else {
                $ptr->{$term} = @val > 1 ? \@val : ref($val[0]) eq 'ARRAY' ? \@val : $val[0];
            }
            $inval = 1;
        } else {
            debug 2, "$term: new level ($s < $lsp)";

            # term:\n -> nest with bracket
            if ($term eq 'fields') {
                $refield = 1;
                $term = 'fieldopts';
            } elsif ($refield) {
                push @{$ret->{fields}}, $term;
            }

            $ptr->{$term} ||= {};
            push @lvl, $ptr;
            $ptr = $ptr->{$term};

            $lsp = $s;       # reset spaces
            $inval = 0;
        }
        $lterm = $term;
    }

    if (ref $self) {
        # add in any top-level options
        while (my($k,$v) = each %$self) {
            $ret->{$k} = $v unless exists $ret->{$k};
        }

        # in FB, this is a class (not object) for speed
        $self->{data}   = $ret;
        $self->{source} = $file;
    }

    return wantarray ? %$ret : $ret;
}