#!/usr/bin/perl -I. use strict; use vars qw($TESTING $DEBUG); $TESTING = 1; $DEBUG = $ENV{DEBUG} || 0; use Test; # use a BEGIN block so we print our plan before CGI::FormBuilder is loaded BEGIN { my $numtests = 26; 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 'header'; use CGI::FormBuilder; # egads this part is annoying due to line disciplines my $h = header(); # What options we want to use, and what we expect to see my @test = ( #1 { opt => { fields => [qw/name email/], sticky => 0 }, res => q(
Name
Email
) }, #2 { opt => { fields => [qw/Upper Case/], values => { Upper => 1, Case => 0 } }, res => q(
Upper
Case
), }, #3 { opt => { fields => [qw/first_name last_name/], submit => 'Update', reset => 0 }, res => q(
First Name
Last Name
), }, #4 { opt => { fields => [qw/first_name last_name/], submit => 'Update', reset => 0, header => 1, body => {bgcolor => 'black'} }, res => $h . q(TEST

TEST

First Name
Last Name
), }, #5 { opt => { fields => {first_name => 'Nate', email => 'nate@wiger.org' }, validate => {email => 'EMAIL'}, required => [qw/first_name/], sticky => 0 }, res => q(

Fields that are highlighted are required.

Email
First Name
), }, #6 { # utilize our query_string to test stickiness opt => { fields => [qw/ticket user part_number/], method => 'POST', keepextras => 1, validate => { ticket => '/^\d+$/' }, submit => [qw/Update Delete Cancel/], lalign => 'LEFT', }, res => q(

Fields that are highlighted are required.

Ticket
User
Part Number
), }, #7 { # max it out, baby opt => { fields => [qw/supply demand/], options => { supply => [0..9], demand => [0..9] }, values => { supply => [0..4], demand => [5..9] }, method => 'PUT', title => 'Econ 101', action => '/nowhere.cgi', header => 1, name => 'econ', font => 'arial,helvetica', fieldtype => 'select' }, res => $h . q(Econ 101

Econ 101

Supply
Demand
 ), }, #8 { opt => { fields => [qw/db:name db:type db:tab ux:user ux:name/], static => 1 }, res => q(
Db Name
Db Type
Db Tab
Ux User
Ux Name
), }, #9 { # single-line search thing ala Yahoo! opt => { fields => 'search', submit => 'Go', reset => 0, table => 0 }, res => q(
Search
), }, #10 { opt => { fields => [qw/hostname domain/], header => 1, keepextras => [qw/user ticket/], values => [qw/localhost localdomain/], validate => {hostname => 'HOST', domain => 'DOMAIN'}, }, res => $h . q(TEST

TEST

Fields that are highlighted are required.

Hostname
Domain
), }, #11 { opt => { fields => {first_name => 'Nate', email => 'nate@wiger.org' }, validate => {email => 'EMAIL'}, required => [qw/first_name/], javascript => 0 }, res => q(

Fields that are highlighted are required.

Email
First Name
), }, #12 { opt => { fields => [qw/earth wind fire water/], fieldattr => {type => 'TEXT'}}, res => q(
Earth
Wind
Fire
Water
), }, #13 { opt => { fields => [qw/earth wind fire water/], options => { wind => [qw/ /], fire => [qw/&&MURDEROUS" &&HOT" &&WARM" &&COLD" &&CHILLY" &&OUT"/], }, values => { water => '>>&c0ld&<<', earth => 'Wind >>' }, }, res => q(
Earth
Wind
Fire
Water
), }, #14 - option maxing { opt => { fields => [qw/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', }, res => q(
Multiopt
), }, #15 - obscure features { opt => { fields => [qw/plain jane mane/], nameopts => 1, stylesheet => '/my/own/style.css', styleclass => 'yo.', body => {ignore => 'me'}, javascript => 0, jsfunc => '// missing', labels => {plain => 'AAA', jane => 'BBB'}, options => {mane => [qw/ratty nappy mr_happy/]}, selectnum => 0, title => 'Bobby', header => 1, }, res => $h . q(Bobby

Bobby

AAA
BBB
Mane
), }, #16 { opt => { fields => [qw/name email/], sticky => 0 }, mod => { name => {comment => 'Hey buddy'}, email => {comment => 'No email >> address??'} }, res => q(
Name Hey buddy
Email No email >> address??
), }, #17 { opt => { fields => [qw/won too many/] }, mod => { won => { jsclick => 'taco_punch = 1'}, too => { options => [0..2], jsclick => 'this.salami.value = "delicious"'}, many => { options => [0..9], jsclick => 'this.ham.value = "it\'s a pig, man!"'}, }, res => q(
Won
Too
Many
), }, #18 { opt => { fields => [qw/refsort/] }, mod => { refsort => { sortopts => \&refsort, options => [qw/99 9 8 83 7 73 6 61 66 5 4 104 3 2 10 1 101/] } }, res => q(
Refsort
), }, #19 - table attr and field columns { opt => { fields => [qw/a b c/], table => { border => 1 }, td => { taco => 'beef', align => 'right' }, tr => { valign => 'top' }, th => { ignore => 'this' }, lalign => 'today', selectnum => 10, }, mod => { a => { options => [0..3], columns => 2, value => [1..2] }, b => { options => [4..9], columns => 3, comment => "Please fill these in" }, }, res => q(
A
B
Please fill these in
C
), }, #20 - order.cgi from manpage (big) { opt => { method => 'POST', fields => [ qw(first_name last_name email send_me_emails address state 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', }, required => 'ALL', jsfunc => < { state => { options => [qw(JS IW KS UW JS UR EE DJ HI YK NK TY)], sortopts=> 'NAME' }, send_me_emails => { options => [[1 => 'Yes'], [0 => 'No']], value => 0, # "No" }, }, res => $h . q(Finalize Your Order

Finalize Your Order

Fields that are highlighted are required.

First Name
Last Name
Email
Send Me Emails
Address
State
Zipcode
Credit Card
Expiration
), }, #21 - "other" fields { opt => { javascript => 1 }, mod => { favorite_color => { name => 'favorite_color', options => [qw(red green blue yellow)], validate => 'NAME', other => 1 } }, res => q(
Favorite Color
), }, #22 - "other" fields { opt => { javascript => 0, method => "POST", }, mod => { favorite_color => { name => 'favorite_color', options => [qw(red green blue yellow)], validate => 'NAME', other => 1 } }, res => q(
Favorite Color
), }, #23 - growable fields { opt => {}, mod => { favorite_color => { name => 'favorite_color', growable => 1 } }, res => q(
Favorite Color
), }, #24 - growable fields { opt => {javascript => 0}, mod => { favorite_color => { name => 'favorite_color', growable => 1 } }, res => q(
Favorite Color
), }, #25 - sessionids and fieldopts { opt => { sessionid => 'H8N0TAC5', header => 1, fields => [qw(acct: phone() taco.punch salad$)], fieldopts => { 'acct:' => { true => 'false', label => 'Acct #:' }, 'phone()' => { options => [1] }, missing => { value => 'not here', force => 1} }, }, res => join "\r\n", 'Set-Cookie: _sessionid=H8N0TAC5; path=/', 'EXPIRES', 'Content-Type: text/html; charset=ISO-8859-1', '', q(TEST

TEST

Acct #:
Phone
Taco
Salad
), }, #26 - disabled forms { opt => { disabled => 'YES', cleanopts => 0, fields => [qw(acct phone taco salad)], fieldopts => {acct => {type => 'radio', options => [qw(on OFF)]}} }, res => q(
Acct
Phone
Taco
Salad
), }, ); sub refsort { $_[0] <=> $_[1] } # Perl is sick. @test = @test[$ARGV[0] - 1] if @ARGV; # Cycle thru and try it out for (@test) { my $form = CGI::FormBuilder->new( debug => $DEBUG, action => 'TEST', title => 'TEST', %{ $_->{opt} }); while(my($f,$o) = each %{$_->{mod} || {}}) { $o->{name} = $f; $form->field(%$o); } # just compare the output of render with what's expected my $out; $out = $form->render; $out =~ s/^Date:.*/EXPIRES\r/m; my $ok = ok($out, $_->{res}); if (! $ok && $ENV{LOGNAME} eq 'nwiger') { open(O, ">/tmp/fb.1.out"); print O $_->{res}; close O; open(O, ">/tmp/fb.2.out"); print O $out; close O; system "diff /tmp/fb.1.out /tmp/fb.2.out"; exit 1; } }