File Coverage

lib/CGI/FormBuilder/Source/File.pm

Criterion	Covered	Total	%
statement	117	135	86.6
branch	48	70	68.5
condition	22	41	53.6
subroutine	8	9	88.8
pod	3	3	100.0
total	198	258	76.7

###########################################################################
# Copyright (c) Nate Wiger http://nateware.com. All Rights Reserved.
# Please visit http://formbuilder.org for tutorials, support, and examples.
###########################################################################

package CGI::FormBuilder::Source::File;

=head1 NAME

CGI::FormBuilder::Source::File - Initialize FormBuilder from external file

=head1 SYNOPSIS

    # use the main module
    use CGI::FormBuilder;

    my $form = CGI::FormBuilder->new(source => 'form.conf');

    my $lname = $form->field('lname');  # like normal

=cut

use Carp;
use strict;
use warnings;
no  warnings 'uninitialized';

use 5.006; # or later
use CGI::FormBuilder::Util;


our $VERSION = '3.10';

# Begin "real" code
sub new {
    my $mod = shift;
    my $class = ref($mod) || $mod;
    my %opt = arghash(@_);
    return bless \%opt, $class;
}

sub parse {
    local $^W = 0;  # -w sucks so hard
    my $self = shift;
    my $file = shift || $self->{source};

    $CGI::FormBuilder::Util::DEBUG ||= $self->{debug} if ref $self;

    my $ret = {};   # top level
    my $ptr = $ret; # curr ptr
    my @lvl = ();   # previous levels

    my $s   = 0;    # curr spaces
    my $lsp = 0;    # level spaces
    my $psp = 0;    # prev spaces

    my $refield = 0;
    my @file;
    my $utf8 = 0;   # parse file as utf8

    debug 1, "parsing $file as input source";
    if (ref $file eq 'SCALAR') {
        @file = split /[\r\n]+/, $$file;
    } elsif (ref $file eq 'ARRAY') {
        @file = @$file;
    } else {
        open(F, "<$file") || puke "Cannot read $file: $!";
        @file = ;
        close F;
    }

    my($lterm, $here);  # level term, here string
    my $inval = 0;
    for (@file) {
        next if /^\s*$/ || /^\s*#/;     # blanks and comments
        next if /^\s*\[\%\s*\#|^\s*-*\%\]/;   # TT comments too
        chomp;
        my($term, $line) = split /\s*:\s*/, $_, 2;
        $utf8 = 1 if $term eq 'charset' && $line =~ /^utf/;  # key off charset to decode value
        $line = Encode::decode('utf-8', $line) if $utf8;

        # here string term-inator (har)
        if ($here) {
            if ($term eq $here) {
                undef $here;
                next;
            } else {
                $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

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

sub write_module {
    my $self = shift;
    my $mod  = shift || puke "Missing required Module::Name";
    (my $out = $mod) =~ s/.+:://;
    $out .= '.pm';

    open(M, ">$out") || puke "Can't write $out: $!";

    print M "\n# Generated ".localtime()." by ".__PACKAGE__." $VERSION\n";
    print M <
#
# To use this, you must write a script and then use this module.
# In your script, get this form with "my \$form = $mod->new()"

package $mod;

use CGI::FormBuilder;
use strict;

sub new {
    # $mod->new() calling format
    my \$self = shift if \@_ && \@_ % 2 != 0;

    # data structure from '$self->{source}'
EOH

    require Data::Dumper;
    local $Data::Dumper::Varname = 'form';
    print M "    my ". Data::Dumper::Dumper($self->{data});

    print M <<'EOV';

    # allow overriding of individual parameters
    while (@_) {
        $form1->{shift()} = shift;
    }

    # return a new form object
    return CGI::FormBuilder->new(%$form1);
}

1;
# End of module
EOV

    close M;
    print STDERR "Wrote $out\n";    # send to stderr in case of httpd
}

1;
__END__