| line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
|
1
|
|
|
|
|
|
|
=head1 NAME |
|
2
|
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
Postgres::Handler::HTML - HTML Component for PostgreSQL data. |
|
4
|
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 DESCRIPTION |
|
6
|
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
Accessors for PostgreSQL data. Simplifies data access through a series of standard class methods. |
|
8
|
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=head1 SYNOPSIS |
|
10
|
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
# Instantiate Object |
|
12
|
|
|
|
|
|
|
# |
|
13
|
|
|
|
|
|
|
use Postgres::Handler; |
|
14
|
|
|
|
|
|
|
my $DB = Postgres::Handler->new(dbname=>'products',dbuser=>'postgres',dbpass=>'pgpassword'); |
|
15
|
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
# Retrieve Data & List Records |
|
17
|
|
|
|
|
|
|
# |
|
18
|
|
|
|
|
|
|
$DB->PrepLEX('SELECT * FROM products'); |
|
19
|
|
|
|
|
|
|
while ($item=$DB->GetRecord()) { |
|
20
|
|
|
|
|
|
|
print "$item->{PROD_ID}\t$item->{PROD_TITLE}\t$item->{PROD_QTY}\n"; |
|
21
|
|
|
|
|
|
|
} |
|
22
|
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# Add / Update Record based on CGI Form |
|
24
|
|
|
|
|
|
|
# assuming objCGI is an instatiated CGI object |
|
25
|
|
|
|
|
|
|
# if the CGI param 'prod_id' is set we update |
|
26
|
|
|
|
|
|
|
# if it is not set we add |
|
27
|
|
|
|
|
|
|
# |
|
28
|
|
|
|
|
|
|
my %cgimap; |
|
29
|
|
|
|
|
|
|
foreach ('prod_id','prod_title','prod_qty') { $cgimap{$_} = $_; } |
|
30
|
|
|
|
|
|
|
$DB->AddUpdate( CGI=>$objCGI , CGIKEY=>'prod_id', |
|
31
|
|
|
|
|
|
|
TABLE=>'products', DBKEY=>'prod_id', |
|
32
|
|
|
|
|
|
|
hrCGIMAP=>\%cgimap |
|
33
|
|
|
|
|
|
|
); |
|
34
|
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
=head1 EXAMPLE |
|
36
|
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
#!/usr/bin/perl |
|
38
|
|
|
|
|
|
|
# |
|
39
|
|
|
|
|
|
|
# Connect to the postgres XYZ database owned by user1/mypass |
|
40
|
|
|
|
|
|
|
# Set the primary key field for the abc table to the field named pkid |
|
41
|
|
|
|
|
|
|
# Print the contents of the fldone field in the abc table where the pkid=123 |
|
42
|
|
|
|
|
|
|
# |
|
43
|
|
|
|
|
|
|
use Postgres::Handler::HTML; |
|
44
|
|
|
|
|
|
|
our $STORE = Postgres::Handler::HTML->new(dbname=>'xyz', dbuser=>'user1', dbpass=>'mypass'); |
|
45
|
|
|
|
|
|
|
$STORE->data('abc!PGHkeyfld'=>'pkid'); |
|
46
|
|
|
|
|
|
|
$STORE->ShowThe('abc!fldone',123); |
|
47
|
|
|
|
|
|
|
exit(1); |
|
48
|
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
=head1 REQUIRES |
|
50
|
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
Subclass of Postgres::Handler |
|
52
|
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
Postgres::Handler |
|
54
|
|
|
|
|
|
|
+- CGI::Carp |
|
55
|
|
|
|
|
|
|
+- CGI::Util |
|
56
|
|
|
|
|
|
|
+- Class::Struct |
|
57
|
|
|
|
|
|
|
+- DBI |
|
58
|
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
=cut |
|
60
|
|
|
|
|
|
|
#============================================================================== |
|
61
|
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
#============================================================================== |
|
64
|
|
|
|
|
|
|
# |
|
65
|
|
|
|
|
|
|
# Package Preparation |
|
66
|
|
|
|
|
|
|
# Sets up global variables and invokes required libraries. |
|
67
|
|
|
|
|
|
|
# |
|
68
|
|
|
|
|
|
|
#============================================================================== |
|
69
|
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
package Postgres::Handler::HTML; |
|
71
|
1
|
|
|
1
|
|
23764
|
use base ("Postgres::Handler"); |
|
|
1
|
|
|
|
|
3
|
|
|
|
1
|
|
|
|
|
2631
|
|
|
72
|
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
#require Postgres::Handler; |
|
75
|
|
|
|
|
|
|
#@ISA=qw(Postgres::Handler); |
|
76
|
|
|
|
|
|
|
$VERSION = 1.0; |
|
77
|
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
#============================================================================== |
|
79
|
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
=head1 METHODS |
|
81
|
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
=cut |
|
83
|
|
|
|
|
|
|
#============================================================================== |
|
84
|
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
#-------------------------------------------------------------------- |
|
86
|
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=head2 CheckBox() |
|
88
|
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
Produce an HTML Checkbox for the specified boolean field |
|
90
|
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
Parameters |
|
92
|
|
|
|
|
|
|
TABLE => name of table to get data from |
|
93
|
|
|
|
|
|
|
CBNAME => name to put on the checkbox, defaults to VALUE |
|
94
|
|
|
|
|
|
|
VALUE => field that contains the t/f use to set the checkmark |
|
95
|
|
|
|
|
|
|
LABEL => what to put next to the checkbox as a label (defaults to field name) |
|
96
|
|
|
|
|
|
|
KEY => value of the key used to lookup the data in the database |
|
97
|
|
|
|
|
|
|
CHECKED => set to '1' to check by default if KEY not found |
|
98
|
|
|
|
|
|
|
SCRIPT => script tags (or class tags) to add to checkbox HTML |
|
99
|
|
|
|
|
|
|
NOLABEL => set to '1' to skip printing of label |
|
100
|
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
Action |
|
102
|
|
|
|
|
|
|
prints out the HTML Checkbox, checked if field is true |
|
103
|
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
Return |
|
105
|
|
|
|
|
|
|
0 = failure, sets error message, get with lasterror() |
|
106
|
|
|
|
|
|
|
1 = success |
|
107
|
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
=cut |
|
109
|
|
|
|
|
|
|
#---------------------------- |
|
110
|
|
|
|
|
|
|
sub CheckBox() { |
|
111
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
|
112
|
0
|
|
|
|
|
|
my %options = @_; |
|
113
|
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
# These options must be defined |
|
115
|
|
|
|
|
|
|
# |
|
116
|
0
|
0
|
0
|
|
|
|
if ( |
|
|
|
|
0
|
|
|
|
|
|
117
|
|
|
|
|
|
|
! exists $options{TABLE} || |
|
118
|
|
|
|
|
|
|
! exists $options{VALUE} || |
|
119
|
|
|
|
|
|
|
! exists $options{KEY} |
|
120
|
|
|
|
|
|
|
) { |
|
121
|
0
|
|
|
|
|
|
$self->data(ERRMSG,qq[Postgres::Handler::HTML::Checkbox TABLE '$options{TABLE}' VALUE '$options{VALUE}' and KEY '$options{KEY}' must be defined.]); |
|
122
|
0
|
|
|
|
|
|
return; |
|
123
|
|
|
|
|
|
|
} |
|
124
|
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# Set defaults if not present |
|
126
|
|
|
|
|
|
|
# |
|
127
|
0
|
|
0
|
|
|
|
$options{CBNAME} ||= $options{VALUE}; |
|
128
|
0
|
0
|
0
|
|
|
|
$options{LABEL} ||= $options{VALUE} if (!$options{NOLABEL}); |
|
129
|
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
# Get Data If Not Set |
|
131
|
|
|
|
|
|
|
# |
|
132
|
0
|
|
|
|
|
|
my $val = $self->Field(DATA=>"$options{TABLE}!$options{VALUE}", KEY=>$options{KEY}); |
|
133
|
0
|
0
|
0
|
|
|
|
$val = 1 if (!$val && $options{CHECKED} && !$options{KEY}); |
|
|
|
|
0
|
|
|
|
|
|
134
|
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# Script/Class Optional HTML tag elements |
|
136
|
|
|
|
|
|
|
# |
|
137
|
0
|
|
|
|
|
|
my $tagmod = $options{SCRIPT}; |
|
138
|
|
|
|
|
|
|
|
|
139
|
0
|
0
|
|
|
|
|
my $selector = ($val ? 'checked' : ''); |
|
140
|
0
|
|
|
|
|
|
print qq[ $options{LABEL}]; |
|
141
|
0
|
|
|
|
|
|
return 1; |
|
142
|
|
|
|
|
|
|
} |
|
143
|
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
#-------------------------------------------------------------------- |
|
147
|
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
=head2 Pulldown() |
|
149
|
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
Produce an HTML pulldown menu for the specified table/fields |
|
151
|
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
Parameters |
|
153
|
|
|
|
|
|
|
TABLE => name of table to get data from |
|
154
|
|
|
|
|
|
|
PDNAME => name to put on the pulldown, defaults to VALUE |
|
155
|
|
|
|
|
|
|
VALUE => which field we stick into the option values |
|
156
|
|
|
|
|
|
|
SHOW => which field we spit out on the selection menu, defaults to VALUE |
|
157
|
|
|
|
|
|
|
SELECT => mark the one with this VALUE as selected |
|
158
|
|
|
|
|
|
|
ALLOWBLANK => set to 1 to allow blank selection (noted as ---) |
|
159
|
|
|
|
|
|
|
ORDERBY => special ordering, defaults to SHOW field |
|
160
|
|
|
|
|
|
|
WHERE => filtering selection clause (without WHERE, i.e. pdclass='class1') |
|
161
|
|
|
|
|
|
|
SCRIPT => event script, such as 'onChange="DoSumthin();"' |
|
162
|
|
|
|
|
|
|
PREADD => address to hashref of Add-ons for begining of list |
|
163
|
|
|
|
|
|
|
key = the value |
|
164
|
|
|
|
|
|
|
content = show |
|
165
|
|
|
|
|
|
|
GROUP => group the data |
|
166
|
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
Action |
|
168
|
|
|
|
|
|
|
prints out the HTML pulldown |
|
169
|
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
=cut |
|
171
|
|
|
|
|
|
|
#---------------------------- |
|
172
|
|
|
|
|
|
|
sub Pulldown() { |
|
173
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
|
174
|
0
|
|
|
|
|
|
my %options = @_; |
|
175
|
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# These options must be defined |
|
177
|
|
|
|
|
|
|
# |
|
178
|
0
|
0
|
0
|
|
|
|
if ( |
|
179
|
|
|
|
|
|
|
! exists $options{TABLE} || |
|
180
|
|
|
|
|
|
|
! exists $options{VALUE} |
|
181
|
0
|
|
|
|
|
|
) { return; } |
|
182
|
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
# Set defaults if not present |
|
185
|
|
|
|
|
|
|
# |
|
186
|
0
|
|
0
|
|
|
|
$options{PDNAME} ||= $options{VALUE}; |
|
187
|
0
|
|
0
|
|
|
|
$options{SHOW} ||= $options{VALUE}; |
|
188
|
0
|
|
0
|
|
|
|
$options{ORDERBY} ||= $options{SHOW}; |
|
189
|
0
|
0
|
|
|
|
|
my $where = ($options{WHERE} ? "WHERE $options{WHERE}" : ''); |
|
190
|
0
|
0
|
|
|
|
|
my $group = ($options{GROUP} ? "GROUP BY $options{GROUP}" : ''); |
|
191
|
|
|
|
|
|
|
|
|
192
|
0
|
|
|
|
|
|
print qq[ |
|
193
|
0
|
0
|
|
|
|
|
print qq[] if ($options{ALLOWBLANK}); |
|
194
|
|
|
|
|
|
|
|
|
195
|
0
|
|
|
|
|
|
my $selector; |
|
196
|
0
|
0
|
|
|
|
|
if ( $self->PrepLEX(qq[SELECT $options{VALUE}, $options{SHOW} FROM $options{TABLE} $where $group ORDER BY $options{ORDERBY}]) ) { |
|
197
|
0
|
|
|
|
|
|
while (my ($value,$show) = $self->GetRecord(-rtype=>'ARRAY')) { |
|
198
|
0
|
0
|
|
|
|
|
$selector = (($value eq $options{SELECT}) ? 'selected' : ''); |
|
199
|
0
|
|
|
|
|
|
print qq[]; |
|
200
|
|
|
|
|
|
|
} |
|
201
|
|
|
|
|
|
|
} else { |
|
202
|
0
|
|
|
|
|
|
print $self->lasterror(); |
|
203
|
|
|
|
|
|
|
} |
|
204
|
0
|
|
|
|
|
|
print qq[]; |
|
205
|
|
|
|
|
|
|
} |
|
206
|
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
#-------------------------------------------------------------------- |
|
208
|
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
=head2 RadioButtons() |
|
210
|
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
Produce an HTML Radio Button menu for the specified table/fields |
|
212
|
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
Parameters |
|
214
|
|
|
|
|
|
|
TABLE => name of table to get data from |
|
215
|
|
|
|
|
|
|
RBNAME => name to put on the pulldown, defaults to VALUE |
|
216
|
|
|
|
|
|
|
VALUE => which field we stick into the option values |
|
217
|
|
|
|
|
|
|
SHOW => which field we spit out on the menu, defaults to VALUE |
|
218
|
|
|
|
|
|
|
SELECT => mark the one with this VALUE as selected |
|
219
|
|
|
|
|
|
|
ORDERBY => special ordering, defaults to SHOW field |
|
220
|
|
|
|
|
|
|
WHERE => filtering selection clause (without WHERE, i.e. rbclass='class1') |
|
221
|
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
Action |
|
223
|
|
|
|
|
|
|
prints out the HTML Radio Buttons |
|
224
|
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
=cut |
|
226
|
|
|
|
|
|
|
#---------------------------- |
|
227
|
|
|
|
|
|
|
sub RadioButtons() { |
|
228
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
|
229
|
0
|
|
|
|
|
|
my %options = @_; |
|
230
|
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# These options must be defined |
|
232
|
|
|
|
|
|
|
# |
|
233
|
0
|
0
|
0
|
|
|
|
if ( |
|
234
|
|
|
|
|
|
|
! exists $options{TABLE} || |
|
235
|
|
|
|
|
|
|
! exists $options{VALUE} |
|
236
|
0
|
|
|
|
|
|
) { return; } |
|
237
|
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
# Set defaults if not present |
|
239
|
|
|
|
|
|
|
# |
|
240
|
0
|
|
0
|
|
|
|
$options{RBNAME} ||= $options{VALUE}; |
|
241
|
0
|
|
0
|
|
|
|
$options{SHOW} ||= $options{VALUE}; |
|
242
|
0
|
|
0
|
|
|
|
$options{ORDERBY} ||= $options{SHOW}; |
|
243
|
0
|
0
|
|
|
|
|
my $where = ($options{WHERE} ? "WHERE $options{WHERE}" : ''); |
|
244
|
|
|
|
|
|
|
|
|
245
|
0
|
|
|
|
|
|
my $selector; |
|
246
|
0
|
|
|
|
|
|
$self->PrepLEX(qq[SELECT $options{VALUE}, $options{SHOW} FROM $options{TABLE} $where ORDER BY $options{ORDERBY}]); |
|
247
|
0
|
|
|
|
|
|
while (my ($value,$show) = $self->GetRecord(-rtype=>'ARRAY')) { |
|
248
|
0
|
0
|
|
|
|
|
$selector = (($value eq $options{SELECT}) ? 'checked' : ''); |
|
249
|
0
|
|
|
|
|
|
print qq[$show]; |
|
250
|
|
|
|
|
|
|
} |
|
251
|
|
|
|
|
|
|
} |
|
252
|
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
#-------------------------------------------------------------------- |
|
254
|
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
=head2 ShowHeader() |
|
256
|
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
Display header for retrieved records in an HTML row
|
258
|
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
One of these 2 id required |
|
260
|
|
|
|
|
|
|
DATAREF => reference to hash storing record |
|
261
|
|
|
|
|
|
|
DISPCOLS => reference to array of columns to show, defaults to hash key names |
|
262
|
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
Optional parameters |
|
264
|
|
|
|
|
|
|
FULLNAME => set to 1 to show full field name, otherwise we trunc up to first _ |
|
265
|
|
|
|
|
|
|
SORT => set to 1 to sort keys |
|
266
|
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
=cut |
|
268
|
|
|
|
|
|
|
#---------------------------- |
|
269
|
|
|
|
|
|
|
sub ShowHeader(@) { |
|
270
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
|
271
|
0
|
|
|
|
|
|
my %options = @_; |
|
272
|
0
|
|
|
|
|
|
my $dRef = $options{DATAREF}; |
|
273
|
0
|
|
|
|
|
|
my $key; |
|
274
|
|
|
|
|
|
|
my @keys; |
|
275
|
0
|
|
|
|
|
|
my $kref; |
|
276
|
0
|
|
|
|
|
|
my $disp; |
|
277
|
0
|
|
|
|
|
|
my $cols = 0; |
|
278
|
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# Header Row |
|
280
|
|
|
|
|
|
|
# |
|
281
|
0
|
0
|
|
|
|
|
if ($options{DISPCOLS}) { |
|
282
|
0
|
|
|
|
|
|
$kref = $options{DISPCOLS}; |
|
283
|
|
|
|
|
|
|
} else { |
|
284
|
0
|
0
|
|
|
|
|
@keys = $options{SORT} ? sort keys %{$dRef} : keys %{$dRef}; |
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
285
|
0
|
|
|
|
|
|
$kref = \@keys; |
|
286
|
|
|
|
|
|
|
} |
|
287
|
|
|
|
|
|
|
|
|
288
|
0
|
|
|
|
|
|
print qq[ | ];
|
289
|
0
|
|
|
|
|
|
foreach $key (@{$kref}) { |
|
|
0
|
|
|
|
|
|
|
|
290
|
0
|
|
|
|
|
|
$disp = $key; |
|
291
|
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
# Full Name or Trunc to first _? |
|
293
|
|
|
|
|
|
|
# |
|
294
|
0
|
0
|
|
|
|
|
if (!$options{FULLNAME}) { $disp =~ s/(.*?)_//; } |
|
|
0
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
|
|
296
|
0
|
|
|
|
|
|
print qq[\n\t | $disp | ];
|
297
|
0
|
|
|
|
|
|
++$cols; |
|
298
|
|
|
|
|
|
|
} |
|
299
|
0
|
|
|
|
|
|
print qq[ | ];
|
300
|
0
|
|
|
|
|
|
return $cols; |
|
301
|
|
|
|
|
|
|
} |
|
302
|
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
#-------------------------------------------------------------------- |
|
304
|
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
=head2 ShowRecord() |
|
306
|
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
Display retrieved records in an HTML row
|
308
|
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
Parameters |
|
310
|
|
|
|
|
|
|
DATAREF => reference to hash storing record (required) |
|
311
|
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
DATAMODREF => reference to hash storing data modifiers |
|
313
|
|
|
|
|
|
|
The field specified by the hash key is replaced |
|
314
|
|
|
|
|
|
|
with the data specified in the value. |
|
315
|
|
|
|
|
|
|
Use $Record{???} to place the record field ??? within |
|
316
|
|
|
|
|
|
|
the substitution string. |
|
317
|
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
If the modifier starts with ~eval() then the modifier |
|
319
|
|
|
|
|
|
|
evaluates and returns it's result. For example: |
|
320
|
|
|
|
|
|
|
$datmodref{THISFIELD} = '~eval(substr($Record{FIELD},0,10))'; |
|
321
|
|
|
|
|
|
|
would display the first 10 characters of the field. |
|
322
|
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
DISPLAYREF => reference to hash storing special cell formats for |
|
324
|
|
|
|
|
|
|
each data element. Key = element, value = | modifier |
|
325
|
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
DISPCOLS => reference to array of columns to show, defaults to hash key names |
|
327
|
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
TRIMDATES => set to 'minute' or 'day' to trim date fields |
|
329
|
|
|
|
|
|
|
date fields are any ending in 'LASTUPDATE' |
|
330
|
|
|
|
|
|
|
WRAP => set to 1 to allow data wrapping |
|
331
|
|
|
|
|
|
|
SORT => set to 1 to sort keys |
|
332
|
|
|
|
|
|
|
ASFORM => set to 1 to show data as input form fields |
|
333
|
|
|
|
|
|
|
NOTABLE => set to 1 to drop all table html tags |
|
334
|
|
|
|
|
|
|
OUTPUT => output file handle |
|
335
|
|
|
|
|
|
|
ROWMOD => modifier to | row definition
|
336
|
|
|
|
|
|
|
CELLMOD => modifier to each | Cell definition |
|
337
|
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
=cut |
|
339
|
|
|
|
|
|
|
#---------------------------- |
|
340
|
|
|
|
|
|
|
sub ShowRecord(@) { |
|
341
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
|
342
|
0
|
|
|
|
|
|
my %options = @_; |
|
343
|
0
|
|
|
|
|
|
my $dRef = $options{DATAREF}; |
|
344
|
0
|
|
|
|
|
|
my $dModRef = $options{DATAMODREF}; |
|
345
|
0
|
|
|
|
|
|
my $DispRef = $options{DISPLAYREF}; |
|
346
|
0
|
0
|
|
|
|
|
my $wrap = ($options{WRAP} ? '' : 'nowrap'); |
|
347
|
0
|
|
|
|
|
|
my $key; |
|
348
|
|
|
|
|
|
|
my @keys; |
|
349
|
0
|
|
|
|
|
|
my $kref; |
|
350
|
0
|
|
|
|
|
|
my $data; |
|
351
|
0
|
|
|
|
|
|
my $temp; |
|
352
|
0
|
|
|
|
|
|
my $dval; |
|
353
|
0
|
|
|
|
|
|
my $fldname; |
|
354
|
0
|
|
0
|
|
|
|
$options{OUTPUT} = $options{OUTPUT} || STDOUT; |
|
355
|
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# Display Order |
|
357
|
|
|
|
|
|
|
# |
|
358
|
0
|
0
|
|
|
|
|
if ($options{DISPCOLS}) { |
|
359
|
0
|
|
|
|
|
|
$kref = $options{DISPCOLS}; |
|
360
|
|
|
|
|
|
|
} else { |
|
361
|
0
|
0
|
|
|
|
|
@keys = $options{SORT} ? sort keys %{$dRef} : keys %{$dRef}; |
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
362
|
0
|
|
|
|
|
|
$kref = \@keys; |
|
363
|
|
|
|
|
|
|
} |
|
364
|
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
# Data Row |
|
366
|
|
|
|
|
|
|
# |
|
367
|
0
|
0
|
|
|
|
|
if (!$options{NOTABLE}) { print {$options{OUTPUT}} qq[ | ]; }
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
368
|
0
|
|
|
|
|
|
foreach $key (@{$kref}) { |
|
|
0
|
|
|
|
|
|
|
|
369
|
0
|
|
|
|
|
|
$data = $dRef->{$key}; |
|
370
|
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
# Date field & Trim Set |
|
372
|
|
|
|
|
|
|
# |
|
373
|
0
|
0
|
0
|
|
|
|
if ($options{TRIMDATES} && ($key =~ /LASTUPDATE$/)) { |
|
374
|
0
|
0
|
|
|
|
|
$data = ( |
|
|
|
0
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
$options{TRIMDATES} =~ /^minute$/i ? substr($dRef->{$key},0,16) : |
|
376
|
|
|
|
|
|
|
$options{TRIMDATES} =~ /^day$/i ? substr($dRef->{$key},0,10) : |
|
377
|
|
|
|
|
|
|
$dRef->{$key} |
|
378
|
|
|
|
|
|
|
); |
|
379
|
|
|
|
|
|
|
} |
|
380
|
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
# Setup Input Modifiers For "ASFORM" |
|
382
|
|
|
|
|
|
|
# |
|
383
|
0
|
0
|
|
|
|
|
if ($options{ASFORM}) { $dModRef->{$key} = qq[]; } |
|
|
0
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
# Modifier? |
|
386
|
|
|
|
|
|
|
# |
|
387
|
0
|
0
|
|
|
|
|
if ( $dModRef->{$key} ) { |
|
388
|
0
|
|
|
|
|
|
$data = $dModRef->{$key}; |
|
389
|
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
# Evaluate |
|
391
|
|
|
|
|
|
|
# |
|
392
|
0
|
0
|
|
|
|
|
if ($data =~ /^~eval\(.*\)/o) { |
|
393
|
0
|
|
|
|
|
|
$data =~ s/^~eval\((.*)\)/$1/; |
|
394
|
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
# Replace RECORD{} with field info |
|
396
|
|
|
|
|
|
|
# |
|
397
|
0
|
|
|
|
|
|
while ($data =~ /\$Record{(.*?)}/) { |
|
398
|
0
|
|
|
|
|
|
$fldname = $1; |
|
399
|
0
|
|
|
|
|
|
$dval = $dRef->{$fldname}; |
|
400
|
0
|
|
|
|
|
|
$dval =~ s/'/\\'/gs; |
|
401
|
0
|
|
|
|
|
|
$data =~ s/\$Record{$fldname}/'$dval'/gs; |
|
402
|
|
|
|
|
|
|
} |
|
403
|
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
# Evaluate the expression |
|
405
|
|
|
|
|
|
|
# |
|
406
|
0
|
|
|
|
|
|
$data = eval $data; |
|
407
|
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
# Convert ' in data back to ' |
|
409
|
|
|
|
|
|
|
# |
|
410
|
0
|
|
|
|
|
|
$data =~ s/\\'/'/gs; |
|
411
|
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
# Plain Old Data Substitution |
|
413
|
|
|
|
|
|
|
# |
|
414
|
|
|
|
|
|
|
} else { |
|
415
|
0
|
|
|
|
|
|
$data =~ s/\$Record{(.*?)}/$dRef->{$1}/gs; |
|
416
|
|
|
|
|
|
|
} |
|
417
|
|
|
|
|
|
|
} |
|
418
|
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
# Show The Formatted Data |
|
420
|
|
|
|
|
|
|
# |
|
421
|
0
|
0
|
|
|
|
|
if (!$options{NOTABLE}) { print {$options{OUTPUT}} qq[\n\t | {$key}>]; } |
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
422
|
0
|
|
|
|
|
|
print {$options{OUTPUT}} $data; |
|
|
0
|
|
|
|
|
|
|
|
423
|
0
|
0
|
|
|
|
|
if (!$options{NOTABLE}) { print {$options{OUTPUT}} qq[ | ]; }
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
} |
|
425
|
0
|
0
|
|
|
|
|
if (!$options{NOTABLE}) { print {$options{OUTPUT}} qq[ | ]; }
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
} |
|
427
|
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
#-------------------------------------------------------------------- |
|
430
|
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
=head2 ValOrZero() |
|
432
|
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
Set these CGI parameters to 0 if not defined. Used for checkbox |
|
434
|
|
|
|
|
|
|
form variables when we want to ensure the value is set to 0 (false) |
|
435
|
|
|
|
|
|
|
if they are not set via the CGI interface. |
|
436
|
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
HTML checkboxes are NOT passed to the CGI module if they are not |
|
438
|
|
|
|
|
|
|
checked, so this function helps us out by forcing the assumption |
|
439
|
|
|
|
|
|
|
that the CGI parameters passed here should be 0 if the are not |
|
440
|
|
|
|
|
|
|
received. |
|
441
|
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
Parameters |
|
443
|
|
|
|
|
|
|
[0] - the CGI variable |
|
444
|
|
|
|
|
|
|
[1] - an array of CGI parameters to be set |
|
445
|
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
Action |
|
447
|
|
|
|
|
|
|
Sets the named CGI parameters to 0 if they are not set, otherwise |
|
448
|
|
|
|
|
|
|
leaves the original value intact. |
|
449
|
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
=cut |
|
451
|
|
|
|
|
|
|
sub ValOrZero(@) { |
|
452
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
|
453
|
0
|
|
|
|
|
|
my $objCGI= shift; |
|
454
|
0
|
|
|
|
|
|
my @parms = @_; |
|
455
|
|
|
|
|
|
|
|
|
456
|
0
|
|
0
|
|
|
|
foreach (@parms) { $objCGI->param($_ , $objCGI->param($_) || 0); } |
|
|
0
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
} |
|
458
|
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
#-------------------------------------------------------------------- |
|
460
|
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
=head2 ShowThe |
|
462
|
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
Load the DB record and spit out the value of the specified field |
|
464
|
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
=over |
|
466
|
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
=item Parameters |
|
468
|
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
Parameters are positional. |
|
470
|
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
Required |
|
472
|
|
|
|
|
|
|
<0> field name to be displayed in "table!field" format |
|
473
|
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
<1> key, lookup the record based on the Postgres::Handler key |
|
475
|
|
|
|
|
|
|
that has been set for this field. Reference the |
|
476
|
|
|
|
|
|
|
Postgres::Handler->Field method for more info. |
|
477
|
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
Optional |
|
479
|
|
|
|
|
|
|
[2] trim to this many characters |
|
480
|
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
=back |
|
482
|
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
=cut |
|
484
|
|
|
|
|
|
|
sub ShowThe(@) { |
|
485
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
|
486
|
0
|
|
0
|
|
|
|
my $retval = $self->Field(DATA=>$_[0], KEY=>$_[1]) || ''; |
|
487
|
0
|
0
|
0
|
|
|
|
$retval = substr($retval,0,$_[2]) if ($_[2] && ($retval ne '')); |
|
488
|
0
|
|
|
|
|
|
print $retval; |
|
489
|
|
|
|
|
|
|
} |
|
490
|
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
1; |
|
495
|
|
|
|
|
|
|
__END__ |
| |