view release on metacpan or  search on metacpan

eg/example4  view on Meta::CPAN

#        ,POSTCODE  char( 10)
#        ,BIRTHDAY  char( 20)
#        ,NOTES     char(200)
#        )


use strict ;

use CGI qw( :standard :html3 ) ;
use CGI::QuickForm qw( show_form colour ) ;
#use CGI::Carp qw( fatalsToBrowser ) ;
use DBI ;
use HTML::Entities ;
use URI::Escape ;

use vars qw( $VERSION ) ;
$VERSION     = '1.041' ;

my $ACTION  = '.qfdb',

my $ADD     = 'Add' ; 
my $DELETE  = 'Delete' ; 
my $EDIT    = 'Edit' ; 
my $FIND    = 'Find' ; 
my $LIST    = 'List' ; 
my $ORDERBY = 'OrderBy' ; 
my $REMOVE  = 'Remove' ; 
my $SEARCH  = 'Search' ; 
my $UPDATE  = 'Update' ; 
my $WHERE   = 'Where' ; 

# Database specific start
my $SHOW_SQL = 0 ; 


my %COLOUR          = (
    -FORM_BG    => '#FFCAFF',
    -DEL_HEAD   => '#E6BEFF',
    -DEL_FIELD  => '#FFE0E0',
    -DEL_VALUE  => '#FFA9A9',
    -LIST_HEAD  => '#E6BEFF',
    -LIST_BAND1 => '#FAFAFA',
    -LIST_BAND2 => '#EDEDED',
    ) ;

my $TITLE           = 'Contacts' ; 
my $DATABASE        = '/root/web/db/contactsqf' ; 
my $KEYFIELD        = 'ID' ; 
my $INITIAL_ORDERBY = 'ID' ; 
# The XBase driver only supports a single WHERE item and does not support
# LIKE. The CSV driver does not appear to support WHERE at all.
#   my $TABLE    = 'contacts_csv' ;
#   my $CONNECT  = "DBI:CSV:f_dir=$DATABASE" ;
my $TABLE           = 'contacts' ; 
my $CONNECT         = "DBI:XBase:/root/web/db/contactsqf" ; 

my @FIELD    = (
            {
                -DB_NAME   => 'ID',
                -DB_QUOTE  => 1,       # 0 for numeric fields
                -DB_HTML   => 'tt',    # e.g. bold, italic, h1, tt, etc.
                -DB_ALIGN  => 'RIGHT', # LEFT (default), CENTER, RIGHT
                -DB_VALIGN => undef,   # BOTTOM, CENTER, TOP 
                -DB_PREFIX => undef,   # e.g. £ or $ etc.
                -LABEL     => 'ID',
                -END_ROW   => 1,
                -REQUIRED  => 1,
                -maxlen    => 12,
            },
            {
                -DB_NAME   => 'FORENAME',
                -DB_HTML   => undef,
                -LABEL     => 'Forename',
                -REQUIRED  => 1,
                -size      => 25,
                -maxlen    => 50,
            },
            {
                -DB_NAME   => 'SURNAME',
                -DB_HTML   => 'b',
                -LABEL     => 'Surname',
                -END_ROW   => 1,
                -REQUIRED  => 1,
                -size      => 25,
                -maxlen    => 50,
            },
            {
                -DB_NAME   => 'HOMETEL',
                -DB_HTML   => undef,
                -LABEL     => 'Home Tel.',
                -VALIDATE  => \&valid_phone,
                -default   => '01225 ',
            },
            {
                -DB_NAME   => 'WORKTEL',
                -DB_HTML   => undef,
                -LABEL     => 'Work Tel.',
                -END_ROW   => 1,
                -VALIDATE  => \&valid_phone,
                -default   => '01225 ',
            },
            {
                -DB_NAME   => 'MOBILE',
                -DB_HTML   => undef,
                -LABEL     => 'Mobile',
                -VALIDATE  => \&valid_phone,
                -default   => '070 ',
            },
            {
                -DB_NAME   => 'FAX',
                -DB_HTML   => undef,
                -LABEL     => 'Fax',
                -END_ROW   => 1,
                -VALIDATE  => \&valid_phone,
                -default   => '01225 ',
            },
            {
                -DB_NAME   => 'EMAIL',
                -DB_HTML   => 'mailto',
                -DB_ALIGN  => 'CENTER',
                -LABEL     => 'Email',

eg/example4  view on Meta::CPAN

        my $connector = uc param( "$CONNECTOR$i" ) || '' ;
        my $quote     = $fieldref->{-DB_QUOTE} ? "'" : '' ;

        if( $comparison =~ /NULL/o ) {
            $where .= "$field $comparison $connector " ;
        }
        else {
            $where .= "$field $comparison $quote$value$quote $connector " ;
        }
        $excess = $connector ;
    }

    $where =~ s/(?:AND|OR) $//o ;

    $where ;
}


sub label2fieldname {
    my $label = shift ;
    my $fieldname ;

    local $^W = 0 ; # Despite the next we still get undefineds!
    foreach my $fieldref ( @FIELD ) {
        next unless ( defined $fieldref->{-LABEL} and 
                      defined $fieldref->{-DB_NAME} ) ;
        $fieldname = $fieldref->{-DB_NAME}, last 
        if $label eq $fieldref->{-LABEL} ;
    }

    $fieldname ;
}


sub fieldname2label {
    my $fieldname = shift ;
    my $label ;

    foreach my $fieldref ( @FIELD ) {
        next unless ( defined $fieldref->{-LABEL} and 
                      defined $fieldref->{-DB_NAME} ) ;
        $label = $fieldref->{-LABEL}, last 
        if $fieldname eq $fieldref->{-DB_NAME} ; 
    }

    $label ;
}


sub render_field {
    my( $field, $html ) = @_ ;

    if( $html eq 'mailto' or $html eq 'email' ) {
        $field = qq{<a href="mailto:$field">$field</a>} ;
    }
    elsif( $html eq 'url' or $html eq 'web' ) {
        my $protocol = $field =~ m,^(?:http|ftp|gopher|wais|/), ? 
                            '' : 'http://' ;
        $field = qq{<a href="$protocol$field">$field</a>} ;
    }
    elsif( $html eq 'b' or $html eq 'bold' ) {
        $field = qq{<b>$field</b>} ;
    }
    elsif( $html eq 'i' or $html eq 'italic' ) {
        $field = qq{<i>$field</i>} ;
    }
    elsif( $html eq 'bi' or $html eq 'bolditalic' ) {
        $field = qq{<b><i>$field</i></b>} ;
    }
    elsif( $html eq 'tt' or $html eq 'fixed' ) {
        $field = qq{<tt>$field</tt>} ;
    }
    elsif( $html =~ /^h([1-6])$/o ) {
        $field = qq{<h$1>$field</h$1>} ;
    }

    $field ;
}

 
sub get_labels {
    my @label ;

    foreach my $fieldref ( @FIELD ) {
        push @label, $fieldref->{-LABEL} 
        if $fieldref->{-LABEL} and 
           ( ( not defined $fieldref->{-TYPE} ) or
             ( $fieldref->{-TYPE} ne 'hidden' and
               $fieldref->{-TYPE} ne 'submit' ) ) ;
    }

    @label ;
}