File Coverage

blib/lib/CGI/QuickForm.pm

Criterion	Covered	Total	%
statement	16	152	10.5
branch	0	102	0.0
condition	0	71	0.0
subroutine	6	11	54.5
pod	0	2	0.0
total	22	338	6.5

package CGI::QuickForm ; # Documented at the __END__.

# $Id: QuickForm.pm,v 1.71 2002/04/30 11:20:03 mark Exp mark $

require 5.004 ;

use strict ;

use CGI qw( :standard :html3 ) ;
#use CGI::Carp qw( fatalsToBrowser ) ;

use vars qw(
            $VERSION @ISA @EXPORT @EXPORT_OK
            %Translate
            ) ;

$VERSION = '1.93' ;

use Exporter() ;

@ISA     = qw( Exporter ) ;

@EXPORT  = qw( show_form ) ;


# &colour is not documented because at some point it may be moved elsewhere.
@EXPORT_OK = qw( colour color ) ;
*color = \&colour ;
sub colour { qq{$_[1]} }


sub show_form {
    my %form = (
        -LANGUAGE         => 'en',         # Language to use for default messages
        -USER_REQUIRED    => undef,
        -USER_INVALID     => undef,
        -REQUIRED_HTML    => '+',
        -INVALID_HTML     => '*',
        -TITLE            => 'Quick Form', # Default page title and heading
        -INTRO            => undef,
        -HEADER           => undef,
        -FOOTER           => undef,
        -NAME             => '',
        -JSCRIPT          => {},
        -ONSUBMIT         => '',
        -ACCEPT           => \&_on_valid_form,
        -VALIDATE         => undef,        # Call this to validate entire form
        -SIZE             => undef,
        -MAXLENGTH        => undef,
        -ROWS             => undef,
        -COLUMNS          => undef,
        -BORDER           => 0,
        -CHECK            => 1,
        -SPACE            => 0,
        -MULTI_COLUMN     => 0,
        -STYLE_FIELDNAME  => '',
        -STYLE_FIELDVALUE => '',
        -STYLE_BUTTONS    => '',
        -STYLE_ROW        => '',
        -STYLE_DESC       => '',
        -STYLE_WHY        => '',
        -TABLE_OPTIONS    => '',
        -FIELDS           => [ { -LABEL => 'No Fields Specified' } ],
        -BUTTONS          => [ { -name  => 'Submit' } ], # Default button
        @_,
        ) ;

    # Backward compatibility.
    $form{-LANGUAGE} = 'en' if $form{-LANGUAGE} eq 'english' ;
    $form{-BUTTONS}[0]{-name} = $form{-BUTTONLABEL} if $form{-BUTTONLABEL} ;

    if( $form{-LANGUAGE} eq 'user' ) {
        $Translate{'user'}{-REQUIRED} =
            $form{-USER_REQUIRED} || $Translate{'en'}{-REQUIRED} ;
        $Translate{'user'}{-INVALID}  =
            $form{-USER_INVALID}  || $Translate{'en'}{-INVALID} ;
    }
    $Translate{$form{-LANGUAGE}}{-REQUIRED} =~ s/~R~/$form{-REQUIRED_HTML}/go ;
    $Translate{$form{-LANGUAGE}}{-INVALID}  =~ s/~I~/$form{-INVALID_HTML}/go ;

    $form{-REQUIRED} = 0 ; # Assume no fields are required.

    foreach my $style ( qw( FIELDNAME FIELDVALUE BUTTONS DESC WHY ) ) {
        $form{"-STYLE_$style"}  = qq{ $form{"-STYLE_$style"}}
        if $form{"-STYLE_$style"} ;
    }
    $form{"-STYLE_BUTTONS"} = 'center'
    if $form{"-STYLE_BUTTONS"} =~ /^ CENT(?:ER|RE)$/oi ;

    $form{-TABLE_OPTIONS} = " $form{-TABLE_OPTIONS}" if $form{-TABLE_OPTIONS} ;
    $form{-MULTIPART} = 0; # Assume single part forms

    my $i = 0 ;
    foreach my $fieldref ( @{$form{-FIELDS}} ) {
        # We have to write back to the original data, $fieldref only points to
        # a copy.
        foreach my $style ( qw( ROW FIELDNAME FIELDVALUE DESC ) ) {
            my $value = $form{-FIELDS}[$i]{"-STYLE_$style"} || $form{"-STYLE_$style"} ;
            $form{-FIELDS}[$i]{"-STYLE_$style"} = $value ? " $value" : '' ;
        }
        $form{-FIELDS}[$i]{-STYLE_FIELDVALUE} .=
            qq{ colspan="$form{-FIELDS}[$i]{-COLSPAN}"}
            if $form{-FIELDS}[$i]{-COLSPAN} and $form{-MULTI_COLUMN} ; #"

        $form{-FIELDS}[$i]{-LABEL} = $fieldref->{-name}  unless $fieldref->{-LABEL} ;
        $form{-FIELDS}[$i]{-name}  = $fieldref->{-LABEL} unless $fieldref->{-name} ;
        $form{-FIELDS}[$i]{-TYPE}  = 'textfield'         unless $fieldref->{-TYPE} ;
        $form{-MULTIPART} = 1 if $form{-FIELDS}[$i]{-TYPE} eq 'filefield' ;

        $form{-FIELDS}[$i]{-START_ROW} = 1
        if $i == 0 or $form{-FIELDS}[$i - 1]{-END_ROW} or not $form{-MULTI_COLUMN} ;

        $form{-FIELDS}[$i]{-END_ROW}   = 1
        if $i == $#{$form{-FIELDS}} or not $form{-MULTI_COLUMN} ;

        $form{-REQUIRED}               = 1 if $fieldref->{-REQUIRED} ;
        if( $form{-FIELDS}[$i]{-TYPE} eq 'textfield' ) {
            if( $form{-SIZE} and not $fieldref->{-size} ) {
                $form{-FIELDS}[$i]{-size}      = $form{-SIZE} ;
            }
            if( $form{-MAXLENGTH} and not $fieldref->{-maxlength} ) {
                $form{-FIELDS}[$i]{-maxlength} = $form{-MAXLENGTH} ;
            }
        }
        elsif( $form{-FIELDS}[$i]{-TYPE} eq 'textarea' ) {
            if( $form{-ROWS} and not $fieldref->{-rows} ) {
                $form{-FIELDS}[$i]{-rows}      = $form{-ROWS} ;
            }
            if( $form{-COLUMNS} and not $fieldref->{-columns} ) {
                $form{-FIELDS}[$i]{-columns}   = $form{-COLUMNS} ;
            }
        }
        $i++ ;
    }

    if( $form{-CHECK} and param() ) {
        &_check_form( \%form ) ;
    }
    else {
        &_show_form( \%form ) ;
    }
}


sub _check_form {
    my $formref = shift ;

    $formref->{-INVALID} = 0 ;
    my %field ;

    my $i = 0 ;
    foreach my $fieldref ( @{$formref->{-FIELDS}} ) {
        # We have to write back to the original data, $fieldref only points to
        # a copy.
        my( $valid, $why ) =
            defined $fieldref->{-VALIDATE} ?
                  &{$fieldref->{-VALIDATE}}( param( $fieldref->{-name} ) ) :
                  ( 1, '' ) ;
        $formref->{-FIELDS}[$i]{-INVALID} = 1,

        $formref->{-FIELDS}[$i]{-WHY} = $valid ?
            undef : "{-STYLE_WHY}>$why",

        $formref->{-INVALID}++
        if ( $fieldref->{-REQUIRED} and not param( $fieldref->{-name} ) ) or
        not $valid ;

        $field{$fieldref->{-name}} = param( $fieldref->{-name} ) ;
        $i++ ;
    }

    if( not $formref->{-INVALID} and defined $formref->{-VALIDATE} ) {
        # If all the individual parts are valid, check that the record as a
        # whole is valid. The parameters are presented in a name=>value hash.
        my( $valid, $why )   = &{$formref->{-VALIDATE}}( %field ) ;
        $formref->{-INVALID} = not $valid ;
        $formref->{-WHY}     = $why ;
    }

    if( $formref->{-INVALID} ) {
        &_show_form( $formref ) ;
    }
    else {
        # Clean any fields that have a clean routine specified.
        foreach my $fieldref ( @{$formref->{-FIELDS}} ) {
            param( $fieldref->{-name},
                &{$fieldref->{-CLEAN}}( param( $fieldref->{-name} ) ) )
            if defined $fieldref->{-CLEAN} ;
        }
        &{$formref->{-ACCEPT}} ;
    }
}


sub _show_form {
    my $formref = shift ;

    my $invalid = delete $formref->{-INVALID} ;
    my $why     = delete $formref->{-WHY} ;
    my $n       = delete $formref->{-SPACE} ? "\n" : '' ;

    if( $formref->{-HEADER} ) {
	if ( ref $formref->{-HEADER} eq 'CODE' ) {
	    &{$formref->{-HEADER}} ;
	}
	else {
	    print "$formref->{-HEADER}$n" ;
	}
    }
    else {
        print
            header,
            start_html(
		-title  => $formref->{-TITLE},
		-script => $formref->{-JSCRIPT} ), $n,
            h3( $formref->{-TITLE} ), $n,
            p( $formref->{-INTRO} || $Translate{$formref->{-LANGUAGE}}{-INTRO} ), $n,
            ;
    }

    print "{-STYLE_WHY}>$why$n"
    if $invalid and defined $why ;
    print "$Translate{$formref->{-LANGUAGE}}{-REQUIRED}$n"
	if $formref->{-REQUIRED} ;
    print " $Translate{$formref->{-LANGUAGE}}{-INVALID}$n"
    if $invalid and not defined $why ;

    my $start_form = $formref->{-MULTIPART} ?
                        \&CGI::start_multipart_form : \&CGI::start_form ;
    if( defined( $ENV{'GATEWAY_INTERFACE'} ) and
        ( $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl/ ) ) {
        print &$start_form(
            -name     => $formref->{-NAME},
            -onSubmit => $formref->{-ONSUBMIT},
            -action   => ( script_name() || '' ) . ( path_info() || '' )
             ), $n ;
    }
    else {
        print &$start_form(
            -name     => $formref->{-NAME},
            -onSubmit => $formref->{-ONSUBMIT}
            ), $n ;
    }

    print qq{$n{-TABLE_OPTIONS}>$n} ; #" $n} ; $n" ; $n" if $endrow ; 




246




 





 





 





 





 





 



   




247




0





 





 





 





 





 



     my @hidden ; 




248




 





 





 





 





 





 



   




249




0





 





 





 





 





 



     foreach my $fieldref ( @{$formref->{-FIELDS}} ) { 




 




0





 





 





 





 





 



   




250




0





 





 





 





 





 



         my %field      = %$fieldref ; 




251




0





 





 





 





 





 



         my $type       = delete $field{-TYPE} ; 




252




0




  
  0
  




 





 





 





 



         push @hidden, $fieldref   if $type eq 'hidden' ; 




253




0




  
  0
  



  
  0
  




 





 





 



         next if $type eq 'submit' or $type eq 'hidden' ; 




254




0





 





 





 





 





 



         my $required   = delete $field{-REQUIRED} ; 




255




0




  
  0
  




 





 





 





 



         $required      = $required ? $formref->{-REQUIRED_HTML} : '' ; 




256




0





 





 





 





 





 



         my $invalid    = delete $field{-INVALID} ; 




257




0




  
  0
  




 





 





 





 



         $invalid       = $invalid  ? $formref->{-INVALID_HTML}  : '' ; 




258




0





 





 





 





 





 



         my $why        = delete $field{-WHY} ; 




259




0





 





 





 





 





 



         my $rowstyle   = delete $field{-STYLE_ROW} ; 




260




0





 





 





 





 





 



         my $namestyle  = delete $field{-STYLE_FIELDNAME} ; 




261




0





 





 





 





 





 



         my $valuestyle = delete $field{-STYLE_FIELDVALUE} ; 




262




0





 





 





 





 





 



         my $descstyle  = delete $field{-STYLE_DESC} ; 




263




0





 





 





 





 





 



         my $endrow     = delete $field{-END_ROW} ; 




264




0




  
  0
  




 





 





 





 



         if( $field{-HEADLINE} ) { 




265




0





 




  
  0
  




 





 





 



             $field{-COLSPAN} ||= 2 ; 




266




0





 





 





 





 





 



             $namestyle .= qq{ colspan="$field{-COLSPAN}"} ; #" 




267




 





 





 





 





 





 



         } 




268




0




  
  0
  




 





 





 





 



         print qq{$n} if delete $field{-START_ROW} ; 




269




0





 





 





 





 





 



         print qq{$field{-LABEL}$required$invalid




270




0




  
  0
  




 





 





 





 



         unless( $field{-HEADLINE} ) { 




271




0





 





 





 





 





 



             print qq{} ; 




272




0




  
  0
  




 





 





 





 



             print "$field{-DESC}" if $field{-DESC} ; 




273




0





 





 





 





 





 



             delete @field{-LABEL,-VALIDATE,-CLEAN,-SIZE,-MAXLENGTH, 




274




 





 





 





 





 





 



                           -ROWS,-COLUMNS,-COLSPAN} ; 




275




1





 





 




  
1
  




 





7



             no strict "refs" ; 




 




1





 





 





 





 





2



   




 




1





 





 





 





 





707



   




276




0





 





 





 





 





 



             local $^W = 0 ; # Switch off moans about undefined values. 




277




0





 





 





 





 





 



             print &{$type}( %field ) ;  




 




0





 





 





 





 





 



   




278




 





 





 





 





 





 



             # Prefer to say why immediately after the field rather than in a 




279




 





 





 





 





 





 



             # separate column. 




280




0




  
  0
  



  
  0
  




 





 





 



             print " $why" if $invalid and defined $why ; 




281




0





 





 





 





 





 



             print "




282




 





 





 





 





 





 



         } 




283




0




  
  0
  




 





 





 





 



         print "




284




 





 





 





 





 





 



     } 




285




 





 





 





 





 





 



   




286




0




  
  0
  




 





 





 





 



     print "$n", ( ( $formref->{-STYLE_BUTTONS} eq 'center' ) ?

    my @hidden ;

    foreach my $fieldref ( @{$formref->{-FIELDS}} ) {
        my %field      = %$fieldref ;
        my $type       = delete $field{-TYPE} ;
        push @hidden, $fieldref   if $type eq 'hidden' ;
        next if $type eq 'submit' or $type eq 'hidden' ;
        my $required   = delete $field{-REQUIRED} ;
        $required      = $required ? $formref->{-REQUIRED_HTML} : '' ;
        my $invalid    = delete $field{-INVALID} ;
        $invalid       = $invalid  ? $formref->{-INVALID_HTML}  : '' ;
        my $why        = delete $field{-WHY} ;
        my $rowstyle   = delete $field{-STYLE_ROW} ;
        my $namestyle  = delete $field{-STYLE_FIELDNAME} ;
        my $valuestyle = delete $field{-STYLE_FIELDVALUE} ;
        my $descstyle  = delete $field{-STYLE_DESC} ;
        my $endrow     = delete $field{-END_ROW} ;
        if( $field{-HEADLINE} ) {
            $field{-COLSPAN} ||= 2 ;
            $namestyle .= qq{ colspan="$field{-COLSPAN}"} ; #"
        }
        print qq{$n} if delete $field{-START_ROW} ;
        print qq{$field{-LABEL}$required$invalid
        unless( $field{-HEADLINE} ) {
            print qq{} ;
            print "$field{-DESC}" if $field{-DESC} ;
            delete @field{-LABEL,-VALIDATE,-CLEAN,-SIZE,-MAXLENGTH,
                          -ROWS,-COLUMNS,-COLSPAN} ;
            no strict "refs" ;
            local $^W = 0 ; # Switch off moans about undefined values.
            print &{$type}( %field ) ;
            # Prefer to say why immediately after the field rather than in a
            # separate column.
            print " $why" if $invalid and defined $why ;
            print "
        }
        print "
    }

    print "
                        '' : "{-STYLE_BUTTONS}>" ) ;

    foreach my $fieldref ( @{$formref->{-BUTTONS}} ) {
        if( $fieldref->{-DEFAULTS} ) {
            print defaults( $fieldref->{-name} || 'Clear' ), " " ;
        }
        else {
            print $n, submit( %$fieldref ), " " ;
        }
    }

    print ( ( $formref->{-STYLE_BUTTONS} eq 'center' ) ? '' : '' ) ;

    foreach my $fieldref ( @hidden ) {
        my %field = %$fieldref ;
        delete @field{-LABEL,-VALIDATE,-CLEAN,-SIZE,-MAXLENGTH,-ROWS,-COLUMNS,
                      -TYPE,-REQUIRED,-INVALID,-WHY} ;
        print $n, hidden( %field ) ;
    }

    print $n, end_form, $n ;

    if( $formref->{-FOOTER} ) {
	if ( ref $formref->{-FOOTER} eq 'CODE' ) {
	    &{$formref->{-FOOTER}} ;
	}
	else {
	    print "$formref->{-FOOTER}$n" ;
	}
    }
    else {
        print hr, end_html ;
    }
}


sub _on_valid_form {
    # This is included for completeness - if you don't supply your own your
    # form will simply throw away the user's data!

    print
        header,
        start_html( 'Quick Form' ),
        h3( 'Quick Form' ),
        p( "You must define your own &on_valid_form subroutine, otherwise " .
           "the data will simply be thrown away." ),
        end_html,
        ;

    # If using pure mod_perl you should add:
    #   Apache::Constants::OK ;
    # at the end of your on_valid_form routine and
    #   use Apache::Constants qw( :common ) ;
    # along with the other 'use' commands in your program.
}


BEGIN {

    %Translate = (
        'cy' => {
            -INTRO    => "Cofnodwch y wybodaeth.",
            -REQUIRED => "Mae angen llenwi'r adrannau sydd wedi eu clustnodi " .
                         "gyda ~R~.",
            -INVALID  => "Mae'r adrannau sydd wedi eu clustnodi gyda ~I~ " .
                         "yn cynnwys camgymeriadau neu yn wag.",
            },
        'de' => {
            -INTRO    => "Tragen Sie bitte die Informationen ein.",
            -REQUIRED => "Bitte mindestens die mit ~R~ " .
                         "gekennzeichneten Felder ausfüllen.",
            -INVALID  => "Die mit ~I~ gekennzeichneten Felder " .
                         "enthalten Fehler oder sind leer.",
            },
        'en' => {
            -INTRO    => "Please enter the information.",
            -REQUIRED => "Data entry fields marked with ~R~ are required.",
            -INVALID  => "Data entry fields marked with ~I~ contain errors " .
                         "or are empty.",
            },
        'es' => {
            -INTRO    => "Favor de introducir la información.",
            -REQUIRED => "Los campos marcados con ~R~ son requeridos.",
            -INVALID  => "Los campos marcados con ~I~ contienen " .
                         "errores o están en blanco.",
            },
        'fr' => {
            -INTRO    => "Veuillez écrire l'information.",
            -REQUIRED => "Des zones de saisie de données " .
                         "identifiées par " .
                         "~R~ sont exigées.",
            -INVALID  => "Des zones de saisie de données " .
                         "identifiées par ~I~ contenez les " .
                         "erreurs ou soyez vide.",
            },
        'he' => {
            -INTRO    => "ðà äæï ðúåðéí",
            -REQUIRED => " ùãåú çåáä îñåîðéí á ~R~ ",
            -INVALID  => " ùãåú ùâåééí àå øé÷éí îñåîðéí á ~I~",
            },
        ) ;
}


1 ;


__END__