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

    # use the main module
    use CGI::FormBuilder;

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

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

    # form basics
    method: POST
    header: 1
    title:  Account Information

    # define fields
    fields:
        fname:
            label:   First Name
            size:    40

        minit:
            label:   Middle Initial
            size:    1

        lname:
            label:   Last Name
            size:    60

        email:
            size:    80

        phone:
            label:    Home Phone
            comment:  (optional)
            required: 0

        sex:
            label:   Gender
            options: M=Male, F=Female
            jsclick: javascript:alert('Change your mind??')

        # custom options and sorting sub
        state:
            options:  \&getstates
            sortopts: \&sortstates

        datafile:
            label:   Upload Survey Data
            type:    file
            growable:   1

    # validate our above fields
    validate:
        email:  EMAIL
        phone:  /^1?-?\d{3}-?\d{3}-?\d{4}$/

    required: ALL

    # create two submit buttons, and skip validation on "Cancel"
    submit:  Update, Cancel
    jsfunc:  <<EOJS
  // skip validation
  if (this._submit.value == 'Cancel') return true;
EOJS

    # CSS
    styleclass: acctInfoForm
    stylesheet: /style/acct.css

    fields:
        send_me_emails:
            options: Yes No

    fields:
        send_me_emails:
            options: Yes, No

    fields:
        send_me_emails:
            options: 1=Yes, 0=No

    fields:
        send_me_emails:
            options: 1=Yes Please, 0=No Thanks

    fbusers-subscribe@formbuilder.org

    my $source = CGI::FormBuilder::Source::File->new;

    my $source = CGI::FormBuilder::Source::File->new(
                      javascript => 0
                 );

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

    $source->parse('myform.conf');
    $source->write_module('MyForm');    # write MyForm.pm

    # then in your Perl code
    use MyForm;
    my $form = MyForm->new;

    my $form = MyForm->new(
                    header => 1,
                    submit => ['Save Changes', 'Abort']
               );

    table => {cellpadding => 1, cellspacing => 4},
    td    => {align => 'center', bgcolor => 'gray'},
    font  => {face => 'arial,helvetica', size => '+1'},

    table:
        cellpadding: 1
        cellspacing: 4

    td:
        align: center
        bgcolor: gray

    font:
        face: arial,helvetica
        size: +1

###########################################################################
# Copyright (c) 2000-2006 Nate Wiger <nate@wiger.org>. All Rights Reserved.
# Please visit www.formbuilder.org for tutorials, support, and examples.
###########################################################################

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

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

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

our $REVISION = do { (my $r='$Revision: 100 $') =~ s/\D+//g; $r };
our $VERSION = '3.0501';

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

    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 = <F>;
        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;

        # 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

            # <<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 eq 'messages') {
                @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 (@val) {
                    $_ = [ split /\s*=\s*/, $_, 2 ] if /=/;
                }
            }

            # only arrayref on multi values b/c FB is "smart"
            if ($ptr->{$term}) {
                $ptr->{$term} = (ref $ptr->{$term})
                                    ? [ @{$ptr->{$term}}, @val ] : @val > 1 ? \@val : $val[0];
            } else {
                $ptr->{$term} = @val > 1 ? \@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 <<EOH;
#
# 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__