File: x15cgi_form.pl

package info (click to toggle)
libdbd-informix-perl 2003.04-3
  • links: PTS
  • area: contrib
  • in suites: etch, etch-m68k, sarge
  • size: 1,232 kB
  • ctags: 467
  • sloc: perl: 7,349; ansic: 5,340; sh: 184; makefile: 58
file content (211 lines) | stat: -rwxr-xr-x 7,233 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
#!/usr/bin/perl -w
#
# @(#)$Id: x15cgi_form.pl,v 100.1 2002/02/08 22:50:18 jleffler Exp $
#
# Slightly more sophisticated post-processing example CGI script
#
# Copyright 1998 Jonathan Leffler
# Copyright 2000 Informix Software Inc
# Copyright 2002 IBM

# load standard Perl modules
use strict;
use DBI;
use Apache;
use CGI::Apache;
use CGI::Carp;

# Run the rest of the script in a block so there are no globals.
# Globals are shared across scripts in mod_perl.
{

    # the environment variables were set in the Apache configuration
    # file rather than here

    # instantiate a CGI object
    my $q = new CGI::Apache;
    my $clear = $q->param('reset') ? 1 : 0;

    # CGI::Apache doesn't support a suitable delete_all or Delete_all...
    map { $q->delete($_); } $q->param if ($clear);

    #  output the http header and html heading
    print
        $q->header(),
        $q->start_html(-title=>'Customer Enquiry'),
        $q->start_form,
        $q->h1({-align=>'CENTER'}, 'Customer Enquiry'),
        $q->hr;

    # connect to the database, instantiating a database handler
    # and activating an automatic exit and notification on errors
    my $dbh = DBI->connect('dbi:Informix:stores', '', '',
                        { 'PrintError'=>1, 'RaiseError'=>1 })
            or die "Could not connect, stopped\n";

    # Generate a hash of state names in USA and abbreviations from State
    # table in database.  Note that HTML ignores the leading space on None,
    # but Perl does not, which is extremely convenient.
    my (%states) = (' None' => 'None');
    {
    my $ref = $dbh->selectall_arrayref("SELECT code, sname FROM state");
    foreach (@$ref) { $states{${$_}[0]} = ${$_}[1]; }
    }

    # Create array of state abbreviations from state hash above.
    my (@states) = sort keys %states;

    print   "\nCustomer Surname: ",
            $q->textfield(-name=>'lname', -default=>'', -override=>$clear),
            $q->p,
            "\nCompany Name: ",
            $q->textfield(-name=>'company', -default=>'', -override=>$clear),
            $q->p,
            "\nCity: ",
            $q->textfield(-name=>'city', -default=>'', -override=>$clear),
            $q->p,
            "\nState: ",
            CGI::scrolling_list(-name=>'state', -default=>[' None'],
                            -override=>$clear,
                            -size=>6,
                            -values=>\@states,
                            -labels=>\%states),
                $q->br,
                $q->submit,
                $q->submit(-name=>'reset', -value=>'Clear Form'),
                $q->hr;


    if ($q->param)
    {
        my $q_lname = $q->param('lname');
        my $q_company = $q->param('company');
        my $q_city = $q->param('city');
        my $q_state = $q->param('state');
        my $query = "SELECT * FROM Customer";
        my $pad = " WHERE";
        if (defined $q_state && $q_state ne ' None')
        {
            $_ = $q_state;
            s/(..).*/$1/;
            $query .= "$pad State = '$_'";
            $pad = " AND";
        }
        if (defined $q_company && $q_company !~ /^\s*$/)
        {
            $query .= "$pad Company MATCHES '$q_company'";
            $pad = " AND";
        }
        if (defined $q_lname && $q_lname !~ /^\s*$/)
        {
            $query .= "$pad Lname MATCHES '$q_lname'";
            $pad = " AND";
        }
        if (defined $q_city && $q_city !~ /^\s*$/)
        {
            $query .= "$pad City MATCHES '$q_city'";
            $pad = " AND";
        }
        $query .= ' ORDER BY Lname, Fname, Company, Customer_num';

        print $query, $q->hr;

        # prepare the select statement
        my $sth = $dbh->prepare( $query ) or
                die "Could not prepare $query; stopped";

        # open the cursor
        $sth->execute() or die "Failed to open cursor for SELECT statment\n";

        # bind columns to variables
        my ($customer_num, $fname, $lname, $company);
        my ($address1, $address2, $city, $state, $zipcode, $phone);
        my @cols = ( \$customer_num, \$fname, \$lname, \$company,
            \$address1, \$address2, \$city, \$state, \$zipcode, \$phone );
        $sth->bind_columns(undef, @cols);

        # chop blanks from char columns
        $sth->{ ChopBlanks } = 1;

        # fetch records from the database
        my $count = 0;
        while ( $sth->fetch() ) {
            if ($count++ == 0)
            {
                # Start a table with a row of table header rows.
                # Encode the <table> tag manually rather than calling
                # $q->table() to avoid printing the entire table at once
                print
                    $q->h1({ align=>'center' }, 'Customer Report' ),
                    "\n<TABLE>\n",
                    $q->TR( { '-valign'=>'top' },
                        $q->th( { '-align'=>'left' }, [
                            'Name',
                            'Company',
                            'Address',
                            'Phone'
                        ] )
                    );
            }
            # Convert NULLS into empty strings (Perl-ish aka obscure!)
            map { $$_ = "" unless defined $$_ } @cols;
            my ($name) = "$lname, $fname";
            my ($addr) = "$address1" . (($address2 eq "") ? "" : ", $address2") .
                            ", $city $state $zipcode";
            # print values as table cells
            print
                $q->TR( { '-valign'=>'top' },
                    $q->td( [
                        $name,
                        $company,
                        $addr,
                        $phone
                    ] )
                );
        }

        # close the table
        print "\n</TABLE>\n" if $count > 0;
        print   "\n",
                $q->center($q->font({-color=>"#C04040"}, "No customers selected")),
                "\n"
            if $count == 0;

        # This free statement is not strictly necessary in DBD::Informix
        # 0.60 as cursors are auto-finished when the last row is fetched.
        # It is needed in earlier versions; it does no damage in later ones.
        $sth->finish();

        # disconnect from the server
        $dbh->disconnect();

        print $q->hr;

        sub ordinal
        {
            my($val) = @_;
            my($lst) = $val % 10;
            my(@suffix) = ("th", "st", "nd", "rd");
            $lst = 0 if ($lst > 3 || ($val % 100 >= 11 && $val % 100 <= 13));
            return "${val}$suffix[$lst]";
        }

        my ($sec,$min,$hour,$day,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
        $year += 1900;
        my $month = (qw(January February March April May June
                        July August September October November December))[$mon];
        my $weekday = (qw(Sunday Monday Tuesday Wednesday
                        Thursday Friday Saturday))[$wday];
        my $daynum = ordinal($day);
        print $q->center("Data extracted at: $weekday, $daynum $month $year at $hour:$min:$sec UTC\n");
        print $q->hr;
    }

    print $q->end_form;

    # finish the html page
    print $q->end_html();

}

1; # notify Perl that the script loaded successfully