The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

# Copyright (c) Nate Wiger http://nateware.com.
# All Rights Reserved. If you're reading this, you're bored.
# 3a-source-file.t - test C::FB::Source::File support

use strict;

our $TESTING = 1;
our $DEBUG = $ENV{DEBUG} || 0;
our $LOGNAME = $ENV{LOGNAME} || '';
our $VERSION;
BEGIN { $VERSION = '3.09'; }

use Test;
use FindBin;

# use a BEGIN block so we print our plan before CGI::FormBuilder is loaded
BEGIN {
    my $numtests = 20;
    unshift @INC, "$FindBin::Bin/../lib";

    plan tests => $numtests;

    # success if we said NOTEST
    if ($ENV{NOTEST}) {
        ok(1) for 1..$numtests;
        exit;
    }
}


# Need to fake a request or else we stall
$ENV{REQUEST_METHOD} = 'GET';
$ENV{QUERY_STRING}   = 'ticket=111&user=pete&replacement=TRUE&action=Unsubscribe&name=Pete+Peteson&email=pete%40peteson.com&extra=junk';

use CGI::FormBuilder 3.09;
use CGI::FormBuilder::Test;

# For testing sortopts in test 18
sub refsort {
    $_[0] <=> $_[1]
}
sub getopts {
    return [99,9,8,83,7,73,6,61,66,5,4,104,3,2,10,1,101];
}

# What options we want to use, and what we expect to see
my @test = (
    #1
    {
        str => '
fields:
    name
    email
sticky: 0
',
    },

    #2
    {
        str => '
# comment
fields:
    Upper:
        type: password
    Case: 
        value: 3
values:
    Upper: 1
    Case: 0
',
    },

    #3
    {
        str => '
# test three
fields:

    first_name

        last_name

submit: Update

  reset: 0
',
    },

    #4
    {
        str => '
fields:
   first_name
    last_name:
        type: text
submit: Update
reset: 0
header: 1
body:
    bgcolor: black
',
    },

    #5
    {
        str => '
# rewritten fields hash
    # as a set of values
fields:
    email:
        required: 0

    first_name:
        required: 1

values:
     first_name: Nate
     email: nate@wiger.org

validate:
    email: EMAIL
sticky: 0
',
    },

    #6
    {
        # utilize our query_string to test stickiness
        str => '
fields:
    ticket
    user
    part_number

method: post
keepextras: 1

validate:
    ticket: /^\d+$/

submit: Update,Delete,Cancel
',
    },

    #7
    {
        # max it out, baby
        str => '
fields: supply, demand
options:
    supply: 0=A,1=B,2=C,3,4,5,6,7=D,8=E,9=F
    demand: 0=A,1=B,2=C,3,4,5,6,7=D,8=E,9=F

values:
    supply: 0,1,2,3,4
    demand: 5,6,7,8,9

method: put
title:  Econ 101
header
name: econ
font: arial,helvetica,courier
stylesheet: 1
fieldtype: select
',
    },

    #8
    {
        str => '
fields: db:name,db:type,db:tab,ux:user,ux:name
static: 1
',
    },

    #9
    {
        # single-line search thing ala Yahoo!
        str => "fields: search \r\n submit: Go \n\r reset: 0 \r table: 0",
    },

    #10
    {
        str => '
fields:
    hostname
  domain
header: 1

# will come out (ticket,user) b/c of QUERY_STRING
keepextras: user,ticket

values: localhost,localdomain
validate:
    hostname: HOST
  domain:           DOMAIN          
',
    },
 
    #11
    {
        str => '
fields:
    email: 
        value: nate@wiger.org
    first_name:
        value: Nate

validate:
    email: EMAIL

required: first_name

javascript: 0
',
    },

    #12
    {
        str => '
fields: earth, wind, fire, water
fieldattr:
    type: TEXT
',
    },

    #13
    {
        str => '
fields:
    earth
   wind
    columns: 1
  fire
 water
notafield
options:
 wind: <Slow>, <Medium>, <Fast>
   fire: &&MURDEROUS", &&HOT", &&WARM", &&COLD", &&CHILLY", &&OUT"
values:
                            water: >>&c0ld&<<
                                                        earth: Wind >>
            fire: &&MURDEROUS", &&HOT"
',
    },

    #14 - option maxing
    {
        str => '
fields:
    multiopt

values: 
    multiopt: 1,2,6,9

options: 
    multiopt: 1 = One, 2 = Two , 3 = Three, 7 = Seven, 8 = Eight, 9 = Nine,
              4 = Four, 5 = Five,  6 = Six, 10 = Ten
sortopts: NUM,
',
    },

    #15 - obscure features
    {
        str => '
fields: plain, jane,    mane
nameopts: 1

    # Style is important
   stylesheet: /my/own/style.css
   styleclass: yo.

body:
    ignore: me
javascript: 0
jsfunc:// missing
labels:
 plain:AAA
 jane: BBB
options:
 mane: ratty,nappy,mr_happy
selectnum: 0
title: Bobby
header: On
',
    },

    #16
    {
        str => '
fields: 
   name:
        comment: Hey buddy
   email:
     comment: No email >> address??

sticky: 0
',
    },

    #17
    {
        str => '
fields:
    won:
        jsclick: taco_punch = 1, taco_salad = "yummy"
    too:
        options: 0,1,2
        jsclick: this.salami.value = "delicious"
        columns: 1
    many:
        options: 0,1,2,3,4,5,6,7,8,9
        jsclick: this.ham.value = "it\'s a pig, man!"
        columns: 1
    cb_input:
        type: checkbox
        label: Option
        options: active=Have this item active
',
    },

    #18
    {
        str => '
fields:
    refsort:
      sortopts: \&refsort
     options:  \&getopts
',
    },

    #19 - table attr and field columns
    {
        str => '
fields:
    a:
        options: 0,1,2,3
        columns: 2
        value: 1,2
    b:
        options: 4,5,6,7,8,9
        columns: 3
        comment: Please fill these in

    c

lalign: today

table:
    border: 1
td:
    taco: beef
    align: right
tr:
    valign: top
th: 
    ignore: this
selectnum: 10
',
        mod => { a => { options => [0..3], columns => 2, value => [1..2] },
                 b => { options => [4..9], columns => 3, comment => "Please fill these in" },
               },
    },

    #20 - order.cgi from manpage (big)
    {
        str => '
name: order
method: post
fields:
  first_name
  last_name
  email
  send_me_emails:
     options: 1=Yes,0=No
     columns: 1
     value: 0
  address
  state:
        options: JS,IW,KS,UW,JS,UR,EE,DJ,HI,YK,NK,TY
        sortopts: NAME
        columns: 1
  zipcode
  credit_card
  expiration

header: 1,
title:  Finalize Your Order
submit: Place Order, Cancel
reset: 0

validate:
    email: EMAIL
    zipcode: ZIPCODE
  credit_card: CARD
   expiration: MMYY

messages:
    form_invalid_text:  You fucked up. Check it:
    form_required_text: Don\'t fuck up, it causes me work. Fuck,try again, ok?
    js_invalid_input:   - Enter shit in the "%s" field

required: ALL
jsfunc: <<EOJS
    // skip validation if they clicked "Cancel"
    if (form._submit.value == \'Cancel\') return true;
EOJS
',
    },
);

# Perl is sick.
@test = @test[$ARGV[0] - 1] if @ARGV;
my $seq = $ARGV[0] || 1;

# Cycle thru and try it out
for (@test) {

    my %conf = (source => {type => 'File', source => \"$_->{str}"});
    $conf{action} = 'TEST';

    my $form = CGI::FormBuilder->new(%conf);
    $form->{title} = 'TEST' unless $form->{title};

    # just compare the output of render with what's expected
    my $ren = $form->render;
    my $out = outfile($seq++);
    my $ok = ok($ren, $out);

    if (! $ok && $LOGNAME eq 'nwiger') {

        open(O, ">/tmp/fb.1.html");
        print O $out;
        close O;

        open(O, ">/tmp/fb.2.html");
        print O $ren;
        close O;

        system "diff /tmp/fb.1.html /tmp/fb.2.html";
        exit 1;
    }
}