File Coverage

blib/lib/DBIx/CodeKit.pm
Criterion Covered Total %
statement 15 270 5.5
branch 0 134 0.0
condition 0 61 0.0
subroutine 5 24 20.8
pod 2 15 13.3
total 22 504 4.3


line stmt bran cond sub pod time code
1             package DBIx::CodeKit;
2              
3 1     1   32391 use strict;
  1         2  
  1         44  
4 1     1   6 use warnings;
  1         2  
  1         34  
5 1     1   4 use Carp;
  1         6  
  1         75  
6              
7 1     1   5 use vars qw( $VERSION );
  1         2  
  1         2810  
8             $VERSION = '1.07';
9              
10             =head1 NAME
11              
12             DBIx::CodeKit - Universal Code Table Interface
13              
14             =head1 SYNOPSIS
15              
16             use DBIx::CodeKit;
17            
18             my $ck = new DBIx::CodeKit($dbh,
19             table => 'ck_code',
20             getparam => sub { $cgi->param(shift) },
21             getparams => sub { $cgi->param(shift.'[]') }
22             );
23              
24             =cut
25              
26             ### See the rest of the pod documentation at the end of this file. ###
27              
28             sub new {
29 0     0 0   my $class = shift;
30 0           my $dbh = shift;
31 0 0         my $args = ref($_[0]) ? shift : { @_ };
32 0           my $self = {};
33 0           bless $self, $class;
34              
35 0 0         croak 'DBIx::CodeKit->new($dbh): $dbh is not an object' unless ref $dbh;
36 0           $self->{dbh} = $dbh;
37              
38 0   0       $self->{table} = $args->{table} || 'ck_code';
39 0           $self->{getparam} = $args->{getparam};
40 0           $self->{getparams} = $args->{getparams};
41              
42 0           return $self;
43             }
44              
45              
46             # # # HTML display methods.
47              
48             sub desc {
49 0     0 0   my $self = shift;
50 0           return &htmlspecialchars( $self->data(@_) );
51             }
52              
53             sub ucfirst {
54 0     0 0   my $self = shift;
55 0           return CORE::ucfirst( $self->desc(@_) );
56             }
57              
58             sub ucwords {
59 0     0 0   my $self = shift;
60 0           my $str = $self->desc(@_);
61 0           $str =~ s/(^|\s)([a-z])/$1\u$2/g;
62 0           return $str;
63             }
64              
65              
66             # # # Data methods.
67              
68             sub data {
69 0     0 0   my $self = shift;
70 0           my $code_set = shift;
71 0           my $code_code = shift;
72 0           $code_code .= ''; # DBI needs strings here.
73 0 0         $self->{data_sth} = $self->{dbh}->prepare("
74             select code_desc
75             from $self->{table}
76             where code_set = ?
77             and code_code = ?
78             ") unless $self->{data_sth};
79 0           $self->{data_sth}->execute($code_set, $code_code);
80 0           my $code_desc = $self->{data_sth}->fetchrow;
81 0 0         $code_desc = '' unless defined $code_desc; # Avoid warnings.
82 0           return $code_desc;
83             }
84              
85              
86             # # # HTML select single value methods:
87              
88             sub select {
89 0     0 1   my $self = shift;
90 0           my $code_set = shift;
91 0 0         my $args = ref($_[0]) ? shift : { @_ };
92              
93 0   0       my $var_name = $args->{var_name} || $code_set;
94 0           my $value = $args->{value};
95 0           my $default = $args->{default};
96 0           my $subset = $args->{subset};
97 0           my $options = $args->{options};
98 0           my $select_prompt = $args->{select_prompt};
99 0           my $blank_prompt = $args->{blank_prompt};
100              
101             # Variable setup.
102 0           $value = $self->_getparam($var_name, $value, $default);
103 0           my $Subset = &keyme($subset);
104 0 0         $options = $options ? " $options" : '';
105 0 0         $select_prompt = '' unless defined $select_prompt;
106 0 0         $blank_prompt = '' unless defined $blank_prompt;
107              
108             # Drop down box.
109 0           my $select = "
110              
111             # Blank options.
112 0           my $selected = '';
113 0 0         if ($value eq '') {
    0          
114 0 0         if ($select_prompt eq '') {
115 0           $select_prompt =
116             $self->ucwords('code_set', $code_set) . '?';
117             }
118 0           $select .= "
119 0           $selected = 1;
120             } elsif ($blank_prompt ne '') {
121 0           $select .= "
122             }
123              
124             # Show code set options.
125 0           my $set_list = $self->code_set($code_set);
126 0           for my $row ( @$set_list ) {
127 0           my ($code_code, $code_desc) = @$row;
128 0 0 0       next if ($Subset && !$Subset->{$code_code} && $code_code ne $value);
      0        
129 0           $code_desc = htmlspecialchars(CORE::ucfirst($code_desc));
130              
131 0 0         if ($code_code eq $value) {
    0          
132 0           $selected = 1;
133 0           $select .= "
134             } elsif ($row->[3] ne 'd') {
135 0           $select .= "
136             }
137             }
138              
139             # Show a missing value.
140 0 0         if (!$selected) {
141 0           $select .= "
142             }
143              
144 0           $select .= "\n";
145 0           return $select;
146             }
147              
148             sub radio {
149 0     0 0   my $self = shift;
150 0           my $code_set = shift;
151 0 0         my $args = ref($_[0]) ? shift : { @_ };
152              
153 0   0       my $var_name = $args->{var_name} || $code_set;
154 0           my $value = $args->{value};
155 0           my $default = $args->{default};
156 0           my $subset = $args->{subset};
157 0           my $options = $args->{options};
158 0           my $blank_prompt = $args->{blank_prompt};
159 0           my $sep = $args->{sep};
160              
161             # Variable setup.
162 0           $value = $self->_getparam($var_name, $value, $default);
163 0           my $Subset = &keyme($subset);
164 0 0         $options = $options ? " $options" : '';
165 0 0         $blank_prompt = '' unless defined $blank_prompt;
166 0 0         $sep = "
\n" unless defined $sep;
167              
168             # Blank options.
169 0           my $select = '';
170 0           my $selected = '';
171 0 0         if ($value eq '') {
172 0           $selected = 1;
173 0 0         if ($blank_prompt ne '') {
174 0           $select .= "
175 0           $select .= " value=\"\" checked>$blank_prompt";
176             }
177             } else {
178 0 0         if ($blank_prompt ne '') {
179 0           $select .= "
180 0           $select .= " value=\"\">$blank_prompt";
181             }
182             }
183              
184             # Show code set options.
185 0           my $set_list = $self->code_set($code_set);
186 0           for my $row ( @$set_list ) {
187 0           my ($code_code, $code_desc) = @$row;
188 0 0 0       next if ($Subset && !$Subset->{$code_code} && $code_code ne $value);
      0        
189 0           $code_desc = htmlspecialchars(CORE::ucfirst($code_desc));
190 0 0         if ( $code_code eq $value ) {
    0          
191 0           $selected = 1;
192 0 0         $select .= $sep if $select;
193 0           $select .= "
194 0           $select .= " value=\"$code_code\" checked>$code_desc";
195             } elsif ($row->[3] ne 'd') {
196 0 0         $select .= $sep if $select;
197 0           $select .= "
198 0           $select .= " value=\"$code_code\">$code_desc";
199             }
200             }
201              
202             # Show missing values.
203 0 0         if (!$selected) {
204 0 0         $select .= $sep if $select;
205 0           $select .= "
206 0           $select .= " value=\"$value\" checked>$value";
207             }
208              
209 0           return $select;
210             }
211              
212              
213             # # # HTML select multiple value methods:
214              
215             sub multiple {
216 0     0 1   my $self = shift;
217 0           my $code_set = shift;
218 0 0         my $args = ref($_[0]) ? shift : { @_ };
219              
220 0   0       my $var_name = $args->{var_name} || $code_set;
221 0           my $value = $args->{value};
222 0           my $default = $args->{default};
223 0           my $subset = $args->{subset};
224 0           my $options = $args->{options};
225 0           my $size = $args->{size};
226              
227             # Variable setup.
228 0           my $Value = $self->_getparams($var_name, $value, $default);
229 0           my $Subset = &keyme($subset);
230 0 0         $options = $options ? " $options" : '';
231              
232             # Select multiple box.
233 0           my $select = "
234 0 0         $select .= " size=\"$size\"" if ($size);
235 0           $select .= ">\n";
236              
237             # Show code set options.
238 0           my $set_list = $self->code_set($code_set);
239 0           for my $row ( @$set_list ) {
240 0           my ($code_code, $code_desc) = @$row;
241 0 0 0       next if ($Subset && !$Subset->{$code_code} && !$Value->{$code_code});
      0        
242 0           $code_desc = htmlspecialchars(CORE::ucfirst($code_desc));
243 0 0         if ( $Value->{$code_code} ) {
    0          
244 0           $select .= "
245 0           delete $Value->{$code_code};
246             } elsif ($row->[3] ne 'd') {
247 0           $select .= "
248             }
249             }
250              
251             # Show missing values.
252 0           for my $code_code ( keys %$Value ) {
253 0           $select .= "
254             }
255              
256 0           $select .= "\n";
257 0           return $select;
258             }
259              
260             sub checkbox {
261 0     0 0   my $self = shift;
262 0           my $code_set = shift;
263 0 0         my $args = ref($_[0]) ? shift : { @_ };
264              
265 0   0       my $var_name = $args->{var_name} || $code_set;
266 0           my $value = $args->{value};
267 0           my $default = $args->{default};
268 0           my $subset = $args->{subset};
269 0           my $options = $args->{options};
270 0           my $sep = $args->{sep};
271              
272             # Variable setup.
273 0           my $Value = $self->_getparams($var_name, $value, $default);
274 0           my $Subset = &keyme($subset);
275 0 0         $options = $options ? " $options" : '';
276 0 0         $sep = "
\n" unless defined $sep;
277              
278             # Show code set options.
279 0           my $select;
280 0           my $set_list = $self->code_set($code_set);
281 0           for my $row ( @$set_list ) {
282 0           my ($code_code, $code_desc) = @$row;
283 0 0 0       next if ($Subset && !$Subset->{$code_code} && !$Value->{$code_code});
      0        
284 0           $code_desc = htmlspecialchars(CORE::ucfirst($code_desc));
285 0 0         if ( $Value->{$code_code} ) {
    0          
286 0 0         $select .= $sep if $select;
287 0           $select .= "
288 0           $select .= "$options value=\"$code_code\" checked>$code_desc";
289 0           delete $Value->{$code_code};
290             } elsif ($row->[3] ne 'd') {
291 0 0         $select .= $sep if $select;
292 0           $select .= "
293 0           $select .= "$options value=\"$code_code\">$code_desc";
294             }
295             }
296              
297             # Show missing values.
298 0           for my $code_code ( keys %$Value ) {
299 0 0         $select .= $sep if $select;
300 0           $select .= "
301 0           $select .= "$options value=\"$code_code\" checked>$code_code";
302             }
303              
304 0           return $select;
305             }
306              
307              
308             # # # Code Set Methods.
309              
310             sub code_set {
311 0     0 0   my $self = shift;
312 0           my $code_set = shift;
313 0 0         $self->{set_sth} = $self->{dbh}->prepare("
314             select code_code,
315             code_desc,
316             code_order,
317             code_flag
318             from $self->{table}
319             where code_set = ?
320             order by code_order, code_code
321             ") unless $self->{set_sth};
322 0           $self->{set_sth}->execute($code_set);
323 0           return $self->{set_sth}->fetchall_arrayref;
324             }
325              
326              
327             # # # Code Table Updates.
328              
329             sub remove {
330 0     0 0   my $self = shift;
331 0           my $code_set = shift;
332 0           my $code_code = shift;
333 0           $code_code .= ''; # DBI needs strings here.
334 0 0         $self->{remove_sth} = $self->{dbh}->prepare("
335             delete from $self->{table}
336             where code_set = ?
337             and code_code = ?
338             ") unless $self->{remove_sth};
339 0           $self->{remove_sth}->execute($code_set, $code_code);
340             }
341              
342             sub get {
343 0     0 0   my $self = shift;
344 0           my $code_set = shift;
345 0           my $code_code = shift;
346 0 0         $self->{get_sth} = $self->{dbh}->prepare("
347             select code_desc,
348             code_order,
349             code_flag
350             from $self->{table}
351             where code_set = ?
352             and code_code = ?
353             ") unless $self->{get_sth};
354 0           $self->{get_sth}->execute($code_set, $code_code);
355 0           my @info = $self->{get_sth}->fetchrow_array;
356 0           return @info;
357             }
358              
359             sub put {
360 0     0 0   my $self = shift;
361 0           my $code_set = shift;
362 0           my $code_code = shift;
363 0           my $code_desc = shift;
364 0           my $code_order = shift;
365 0           my $code_flag = shift;
366              
367             # Get the existing code info, if any.
368 0           my @old = $self->get($code_set, $code_code);
369              
370             # Field work.
371 0           $code_code .= ''; # DBI needs strings here.
372 0           $code_desc .= '';
373 0 0 0       if (!@old and
      0        
      0        
374             ( not defined($code_order) or $code_order eq '' )
375             and $code_code =~ /^\d+$/) {
376 0           $code_order = $code_code;
377             }
378             { # Argument "" isn't numeric in int. Isn't that int's job?
379 1     1   13 no warnings;
  1         2  
  1         921  
  0            
380 0           $code_order = int($code_order);
381             }
382 0           $code_flag .= '';
383              
384             # Make it so: add, update, or delete.
385 0 0         if (@old) {
    0          
386 0           my ( $old_desc, $old_order, $old_flag ) = @old;
387 0 0         if ($code_desc ne '') {
388 0 0 0       if ($code_desc ne $old_desc ||
      0        
389             $code_order ne $old_order ||
390             $code_flag ne $old_flag) {
391 0           $self->_update($code_set, $code_code,
392             $code_desc, $code_order, $code_flag);
393             }
394             }
395             else {
396 0           $self->remove($code_set, $code_code);
397             }
398             }
399             elsif ($code_desc ne '') {
400 0           $self->_insert($code_set, $code_code,
401             $code_desc, $code_order, $code_flag);
402             }
403             }
404              
405              
406             # # # Private methods.
407              
408             sub _insert {
409 0     0     my $self = shift;
410 0 0         $self->{insert_sth} = $self->{dbh}->prepare("
411             insert into $self->{table} set
412             code_set = ?,
413             code_code = ?,
414             code_desc = ?,
415             code_order = ?,
416             code_flag = ?
417             ") unless $self->{insert_sth};
418 0           $self->{insert_sth}->execute(@_);
419             }
420              
421             sub _update {
422 0     0     my $self = shift;
423 0           my $code_set = shift;
424 0           my $code_code = shift;
425 0           my $code_desc = shift;
426 0           my $code_order = shift;
427 0           my $code_flag = shift;
428 0 0         $self->{update_sth} = $self->{dbh}->prepare("
429             update $self->{table} set
430             code_desc = ?,
431             code_order = ?,
432             code_flag = ?
433             where code_set = ?
434             and code_code = ?
435             ") unless $self->{update_sth};
436 0           $self->{update_sth}->execute(
437             $code_desc,
438             $code_order,
439             $code_flag,
440             $code_set,
441             $code_code
442             );
443             }
444              
445             sub _getparam {
446 0     0     my $self = shift;
447 0           my $var_name = shift;
448 0           my $value = shift;
449 0           my $default = shift;
450 0 0         if ( not defined $value ) {
451 0 0         if ( $self->{getparam} ) {
452 0           $value = &{$self->{getparam}}($var_name);
  0            
453             }
454 0 0         $value = $default unless defined $value;
455 0 0         $value = '' unless defined $value;
456             }
457 0           return $value;
458             }
459              
460             sub _getparams {
461 0     0     my $self = shift;
462 0           my $var_name = shift;
463 0           my $value = shift;
464 0           my $default = shift;
465 0 0         if ( not defined $value ) {
466 0 0         my $call = $self->{getparams} ? $self->{getparams} : $self->{getparam};
467 0 0         if ( $call ) {
468 0           $value = [ grep { defined $_ } &$call($var_name) ];
  0            
469 0 0         $value = $value->[0] if ref $value->[0];
470             }
471 0 0         $value = $default unless defined $value;
472 0 0         $value = '' unless defined $value;
473             }
474 0   0       return &keyme($value) || {};
475             }
476              
477             sub keyme {
478 0     0 0   my $value = shift;
479 0 0         return $value if ref($value) eq 'HASH';
480 0           my $Keyhash;
481 0 0 0       if (ref($value) eq 'ARRAY') {
    0 0        
482 0           for my $val ( @$value ) { $Keyhash->{$val} = 1; }
  0            
483             } elsif (defined($value) && $value ne '' && !ref($value)) {
484 0           $Keyhash->{$value} = 1;
485             }
486 0           return $Keyhash;
487             }
488              
489             sub htmlspecialchars {
490 0     0 0   my $str = shift;
491 0           $str =~ s/&/\&/g;
492 0           $str =~ s/"/\"/g;
493 0           $str =~ s/
494 0           $str =~ s/>/\>/g;
495 0           return $str;
496             }
497              
498             1;
499              
500             __END__