1package DBIx::XHTML_Table; 2 3use strict; 4use warnings; 5our $VERSION = '1.49'; 6 7use DBI; 8use Carp; 9 10# GLOBALS 11use vars qw(%ESCAPES $T $N); 12($T,$N) = ("\t","\n"); 13%ESCAPES = ( 14 '&' => '&', 15 '<' => '<', 16 '>' => '>', 17 '"' => '"', 18); 19 20#################### CONSTRUCTOR ################################### 21 22# see POD for documentation 23sub new { 24 my $class = shift; 25 my $self = { 26 null_value => ' ', 27 }; 28 bless $self, $class; 29 30 # last arg might be GTCH (global table config hash) 31 $self->{'global'} = pop if ref $_[$#_] eq 'HASH'; 32 33 # note: disconnected handles aren't caught :( 34 35 if (UNIVERSAL::isa($_[0],'DBI::db')) { 36 # use supplied db handle 37 $self->{'dbh'} = $_[0]; 38 $self->{'keep_alive'} = 1; 39 } 40 elsif (ref($_[0]) eq 'ARRAY') { 41 # go ahead and accept a pre-built 2d array ref 42 $self->_do_black_magic(@_); 43 } 44 else { 45 # create my own db handle 46 eval { $self->{'dbh'} = DBI->connect(@_) }; 47 carp $@ and return undef if $@; 48 } 49 50 return $self; 51} 52 53#################### OBJECT METHODS ################################ 54 55sub exec_query { 56 my ($self,$sql,$vars) = @_; 57 58 carp "can't call exec_query(): do database handle" unless $self->{'dbh'}; 59 60 eval { 61 $self->{'sth'} = (UNIVERSAL::isa($sql,'DBI::st')) 62 ? $sql 63 : $self->{'dbh'}->prepare($sql) 64 ; 65 $self->{'sth'}->execute(@$vars); 66 }; 67 carp $@ and return undef if $@; 68 69 # store the results 70 $self->{'fields_arry'} = [ @{$self->{'sth'}->{'NAME'}} ]; 71 $self->{'fields_hash'} = $self->_reset_fields_hash(); 72 $self->{'rows'} = $self->{'sth'}->fetchall_arrayref(); 73 carp "can't call exec_query(): no data was returned from query" unless @{$self->{'rows'}}; 74 75 if (exists $self->{'pk'}) { 76 # remove the primary key info from the arry and hash 77 $self->{'pk_index'} = delete $self->{'fields_hash'}->{$self->{'pk'}}; 78 splice(@{$self->{'fields_arry'}},$self->{'pk_index'},1) if defined $self->{'pk_index'}; 79 } 80 81 return $self; 82} 83 84sub output { 85 my ($self,$config,$no_ws) = @_; 86 carp "can't call output(): no data" and return '' unless $self->{'rows'}; 87 88 # have to deprecate old arguments ... 89 if ($no_ws) { 90 carp "scalar arguments to output() are deprecated, use hash reference"; 91 $N = $T = ''; 92 } 93 if ($config and not ref $config) { 94 carp "scalar arguments to output() are deprecated, use hash reference"; 95 $self->{'no_head'} = $config; 96 } 97 elsif ($config) { 98 $self->{'no_head'} = $config->{'no_head'}; 99 $self->{'no_ucfirst'} = $config->{'no_ucfirst'}; 100 $N = $T = '' if $config->{'no_indent'}; 101 if ($config->{'no_whitespace'}) { 102 carp "no_whitespace attrib deprecated, use no_indent"; 103 $N = $T = ''; 104 } 105 } 106 107 return $self->_build_table(); 108} 109 110sub modify { 111 my ($self,$tag,$attribs,$cols) = @_; 112 $tag = lc $tag; 113 114 # apply attributes to specified columns 115 if (ref $attribs eq 'HASH') { 116 $cols = 'global' unless defined( $cols) && length( $cols ); 117 $cols = $self->_refinate($cols); 118 119 while (my($attr,$val) = each %$attribs) { 120 $self->{lc $_}->{$tag}->{$attr} = $val for @$cols; 121 } 122 } 123 # or handle a special case (e.g. <caption>) 124 else { 125 # cols is really attribs now, attribs is just a scalar 126 $self->{'global'}->{$tag} = $attribs; 127 128 # there is only one caption - no need to rotate attribs 129 if (ref $cols->{'style'} eq 'HASH') { 130 $cols->{'style'} = join('; ',map { "$_: ".$cols->{'style'}->{$_} } sort keys %{$cols->{'style'}}) . ';'; 131 } 132 133 $self->{'global'}->{$tag."_attribs"} = $cols; 134 } 135 136 return $self; 137} 138 139sub map_cell { 140 my ($self,$sub,$cols) = @_; 141 142 carp "map_cell() is being ignored - no data" and return $self unless $self->{'rows'}; 143 144 $cols = $self->_refinate($cols); 145 for (@$cols) { 146 my $key; 147 if (defined $self->{'fields_hash'}->{$_}) { 148 $key = $_; 149 } elsif( defined $self->{'fields_hash'}->{lc $_}) { 150 $key = lc $_; 151 } else { 152 SEARCH: for my $k (sort keys %{ $self->{'fields_hash'} }) { 153 if (lc( $k ) eq lc( $_ )) { 154 $key = $k; 155 last SEARCH; 156 } 157 } 158 } 159 next unless $key; 160 $self->{'map_cell'}->{$key} = $sub; 161 } 162 return $self; 163} 164 165sub map_head { 166 my ($self,$sub,$cols) = @_; 167 168 carp "map_head() is being ignored - no data" and return $self unless $self->{'rows'}; 169 170 $cols = $self->_refinate($cols); 171 for (@$cols) { 172 my $key; 173 if (defined $self->{'fields_hash'}->{$_}) { 174 $key = $_; 175 } elsif( defined $self->{'fields_hash'}->{lc $_}) { 176 $key = lc $_; 177 } else { 178 SEARCH: for my $k (sort keys %{ $self->{'fields_hash'} }) { 179 if (lc( $k ) eq lc( $_ )) { 180 $key = $k; 181 last SEARCH; 182 } 183 } 184 } 185 next unless $key; 186 $self->{'map_head'}->{$key} = $sub; 187 } 188 189 return $self; 190} 191 192sub add_col_tag { 193 my ($self,$attribs) = @_; 194 $self->{'global'}->{'colgroup'} = {} unless $self->{'colgroups'}; 195 push @{$self->{'colgroups'}}, $attribs; 196 197 return $self; 198} 199 200sub calc_totals { 201 my ($self,$cols,$mask) = @_; 202 return undef unless $self->{'rows'}; 203 204 $self->{'totals_mask'} = $mask; 205 $cols = $self->_refinate($cols); 206 207 my @indexes; 208 for (@$cols) { 209 my $index; 210 if (exists $self->{'fields_hash'}->{$_}) { 211 $index = $self->{'fields_hash'}->{$_}; 212 } elsif (exists $self->{'fields_hash'}->{lc $_}) { 213 $index = $self->{'fields_hash'}->{lc $_}; 214 } else { 215 SEARCH: for my $k (sort keys %{ $self->{'fields_hash'} }) { 216 if (lc( $k ) eq lc( $_ )) { 217 $index = $self->{'fields_hash'}->{$k}; 218 last SEARCH; 219 } 220 } 221 } 222 push @indexes, $index; 223 } 224 225 $self->{'totals'} = $self->_total_chunk($self->{'rows'},\@indexes); 226 227 return $self; 228} 229 230sub calc_subtotals { 231 my ($self,$cols,$mask,$nodups) = @_; 232 return undef unless $self->{'rows'}; 233 234 $self->{'subtotals_mask'} = $mask; 235 $cols = $self->_refinate($cols); 236 237 my @indexes; 238 for (@$cols) { 239 my $index; 240 if (exists $self->{'fields_hash'}->{$_}) { 241 $index = $self->{'fields_hash'}->{$_}; 242 } elsif (exists $self->{'fields_hash'}->{lc $_}) { 243 $index = $self->{'fields_hash'}->{lc $_}; 244 } else { 245 SEARCH: for my $k (sort keys %{ $self->{'fields_hash'} }) { 246 if (lc( $k ) eq lc( $_ )) { 247 $index = $self->{'fields_hash'}->{$k}; 248 last SEARCH; 249 } 250 } 251 } 252 push @indexes, $index; 253 } 254 255 my $beg = 0; 256 foreach my $end (@{$self->{'body_breaks'}}) { 257 my $chunk = ([@{$self->{'rows'}}[$beg..$end]]); 258 push @{$self->{'sub_totals'}}, $self->_total_chunk($chunk,\@indexes); 259 $beg = $end + 1; 260 } 261 262 return $self; 263} 264 265sub set_row_colors { 266 my ($self,$colors,$myattrib) = @_; 267 268 return $self unless ref $colors eq 'ARRAY'; 269 return $self unless $#$colors >= 1; 270 271 my $ref = ($myattrib) 272 ? { $myattrib => [@$colors] } 273 : { style => {background => [@$colors]} } 274 ; 275 276 $self->modify(tr => $ref, 'body'); 277 278 # maybe that should be global? 279 #$self->modify(tr => $ref); 280 281 return $self; 282} 283 284sub set_col_colors { 285 my ($self,$colors,$myattrib) = @_; 286 287 return $self unless ref $colors eq 'ARRAY'; 288 return $self unless $#$colors >= 1; 289 290 my $cols = $self->_refinate(); 291 292 # trick #1: truncate colors to cols 293 $#$colors = $#$cols if $#$colors > $#$cols; 294 295 # trick #2: keep adding colors 296 #unless ($#$cols % 2 and $#$colors % 2) { 297 my $temp = [@$colors]; 298 push(@$colors,_rotate($temp)) until $#$colors == $#$cols; 299 #} 300 301 my $ref = ($myattrib) 302 ? { $myattrib => [@$colors] } 303 : { style => {background => [@$colors]} } 304 ; 305 306 $self->modify(td => $ref, $_) for @$cols; 307 308 return $self; 309} 310 311sub set_group { 312 my ($self,$group,$nodup,$value) = @_; 313 $self->{'nodup'} = $value || $self->{'null_value'} if $nodup; 314 315 my $index; 316 if ($group =~ /^\d+$/) { 317 $index = $group; 318 } elsif (exists $self->{'fields_hash'}->{$group}) { 319 $index = $self->{'fields_hash'}->{$group}; 320 $self->{'group'} = $group; 321 } elsif (exists $self->{'fields_hash'}->{lc $group}) { 322 $index = $self->{'fields_hash'}->{lc $group}; 323 $self->{'group'} = lc $group; 324 } else { 325 SEARCH: for my $k (sort keys %{ $self->{'fields_hash'} }) { 326 if (lc( $k ) eq lc( $group )) { 327 $index = $self->{'fields_hash'}->{$k}; 328 $self->{'group'} = $k; 329 last SEARCH; 330 } 331 } 332 } 333 334 # initialize the first 'repetition' 335 my $rep = $self->{'rows'}->[0]->[$index]; 336 337 # loop through the whole rows array, storing 338 # the points at which a new group starts 339 for my $i (0..$self->get_row_count - 1) { 340 my $new = $self->{'rows'}->[$i]->[$index]; 341 push @{$self->{'body_breaks'}}, $i - 1 unless ($rep eq $new); 342 $rep = $new; 343 } 344 345 push @{$self->{'body_breaks'}}, $self->get_row_count - 1; 346 347 return $self; 348} 349 350sub set_pk { 351 my $self = shift; 352 my $pk = shift || 'id'; 353 $pk = $pk =~ /^\d+$/ ? $self->_lookup_name($pk) || $pk : $pk; 354 carp "can't call set_pk(): too late to set primary key" if exists $self->{'rows'}; 355 $self->{'pk'} = $pk; 356 357 return $self; 358} 359 360sub set_null_value { 361 my ($self,$value) = @_; 362 $self->{'null_value'} = $value; 363 return $self; 364} 365 366sub get_col_count { 367 my ($self) = @_; 368 my $count = scalar @{$self->{'fields_arry'}}; 369 return $count; 370} 371 372sub get_row_count { 373 my ($self) = @_; 374 my $count = scalar @{$self->{'rows'}}; 375 return $count; 376} 377 378sub get_current_row { 379 return shift->{'current_row'}; 380} 381 382sub get_current_col { 383 return shift->{'current_col'}; 384} 385 386sub reset { 387 my ($self) = @_; 388} 389 390sub add_cols { 391 my ($self,$config) = @_; 392 $config = [$config] unless ref $config eq 'ARRAY'; 393 394 foreach (@$config) { 395 next unless ref $_ eq 'HASH'; 396 my ($name,$data,$pos) = @$_{(qw(name data before))}; 397 my $max_pos = $self->get_col_count(); 398 399 $pos = $self->_lookup_index(ucfirst $pos || '') || $max_pos unless defined $pos && $pos =~ /^\d+$/; 400 $pos = $max_pos if $pos > $max_pos; 401 $data = [$data] unless ref $data eq 'ARRAY'; 402 403 splice(@{$self->{'fields_arry'}},$pos,0,$name); 404 $self->_reset_fields_hash(); 405 splice(@$_,$pos,0,_rotate($data)) for (@{$self->{rows}}); 406 } 407 408 return $self; 409} 410 411sub drop_cols { 412 my ($self,$cols) = @_; 413 $cols = $self->_refinate($cols); 414 415 foreach my $col (@$cols) { 416 my $index = delete $self->{'fields_hash'}->{$col}; 417 splice(@{$self->{'fields_arry'}},$index,1); 418 $self->_reset_fields_hash(); 419 splice(@$_,$index,1) for (@{$self->{'rows'}}); 420 } 421 422 return $self; 423} 424 425###################### DEPRECATED ################################## 426 427sub get_table { 428 carp "get_table() is deprecated. Use output() instead"; 429 output(@_); 430} 431 432sub modify_tag { 433 carp "modify_tag() is deprecated. Use modify() instead"; 434 modify(@_); 435} 436 437sub map_col { 438 carp "map_col() is deprecated. Use map_cell() instead"; 439 map_cell(@_); 440} 441 442#################### UNDER THE HOOD ################################ 443 444# repeat: it only looks complicated 445 446sub _build_table { 447 my ($self) = @_; 448 my $attribs = $self->{'global'}->{'table'}; 449 450 my ($head,$body,$foot); 451 $head = $self->_build_head; 452 $body = $self->{'rows'} ? $self->_build_body : ''; 453 $foot = $self->{'totals'} ? $self->_build_foot : ''; 454 455 # w3c says tfoot comes before tbody ... 456 my $cdata = $head . $foot . $body; 457 458 return _tag_it('table', $attribs, $cdata) . $N; 459} 460 461sub _build_head { 462 my ($self) = @_; 463 my ($attribs,$cdata,$caption); 464 my $output = ''; 465 466 # build the <caption> tag if applicable 467 if ($caption = $self->{'global'}->{'caption'}) { 468 $attribs = $self->{'global'}->{'caption_attribs'}; 469 $cdata = $self->{'encode_cells'} ? $self->_xml_encode($caption) : $caption; 470 $output .= $N.$T . _tag_it('caption', $attribs, $cdata); 471 } 472 473 # build the <colgroup> tags if applicable 474 if ($attribs = $self->{'global'}->{'colgroup'}) { 475 $cdata = $self->_build_head_colgroups(); 476 $output .= $N.$T . _tag_it('colgroup', $attribs, $cdata); 477 } 478 479 # go ahead and stop if they don't want the head 480 return "$output\n" if $self->{'no_head'}; 481 482 # prepare <tr> tag info 483 my $tr_attribs = _merge_attribs( 484 $self->{'head'}->{'tr'}, $self->{'global'}->{'tr'} 485 ); 486 my $tr_cdata = $self->_build_head_row(); 487 488 # prepare the <thead> tag info 489 $attribs = $self->{'head'}->{'thead'} || $self->{'global'}->{'thead'}; 490 $cdata = $N.$T . _tag_it('tr', $tr_attribs, $tr_cdata) . $N.$T; 491 492 # add the <thead> tag to the output 493 $output .= $N.$T . _tag_it('thead', $attribs, $cdata) . $N; 494} 495 496sub _build_head_colgroups { 497 my ($self) = @_; 498 my (@cols,$output); 499 500 return unless $self->{'colgroups'}; 501 return undef unless @cols = @{$self->{'colgroups'}}; 502 503 foreach (@cols) { 504 $output .= $N.$T.$T . _tag_it('col', $_); 505 } 506 $output .= $N.$T; 507 508 return $output; 509} 510 511sub _build_head_row { 512 my ($self) = @_; 513 my $output = $N; 514 my @copy = @{$self->{'fields_arry'}}; 515 516 foreach my $field (@copy) { 517 my $attribs = _merge_attribs( 518 $self->{$field}->{'th'} || $self->{'head'}->{'th'}, 519 $self->{'global'}->{'th'} || $self->{'head'}->{'th'}, 520 ); 521 522 if (my $sub = $self->{'map_head'}->{$field}) { 523 $field = $sub->($field); 524 } 525 elsif (!$self->{'no_ucfirst'}) { 526 $field = ucfirst( lc( $field ) ); 527 } 528 529 # bug 21761 "Special XML characters should be expressed as entities" 530 $field = $self->_xml_encode( $field ) if $self->{'encode_cells'}; 531 532 $output .= $T.$T . _tag_it('th', $attribs, $field) . $N; 533 } 534 535 return $output . $T; 536} 537 538sub _build_body { 539 540 my ($self) = @_; 541 my $beg = 0; 542 my $output; 543 544 # if a group was not set via set_group(), then use the entire 2-d array 545 my @indicies = exists $self->{'body_breaks'} 546 ? @{$self->{'body_breaks'}} 547 : ($self->get_row_count - 1); 548 549 # the skinny here is to grab a slice of the rows, one for each group 550 foreach my $end (@indicies) { 551 my $body_group = $self->_build_body_group([@{$self->{'rows'}}[$beg..$end]]) || ''; 552 my $attribs = $self->{'global'}->{'tbody'} || $self->{'body'}->{'tbody'}; 553 my $cdata = $N . $body_group . $T; 554 555 $output .= $T . _tag_it('tbody',$attribs,$cdata) . $N; 556 $beg = $end + 1; 557 } 558 return $output; 559} 560 561sub _build_body_group { 562 563 my ($self,$chunk) = @_; 564 my ($output,$cdata); 565 my $attribs = _merge_attribs( 566 $self->{'body'}->{'tr'}, $self->{'global'}->{'tr'} 567 ); 568 my $pk_col = ''; 569 570 # build the rows 571 for my $i (0..$#$chunk) { 572 my @row = @{$chunk->[$i]}; 573 $pk_col = splice(@row,$self->{'pk_index'},1) if defined $self->{'pk_index'}; 574 $cdata = $self->_build_body_row(\@row, ($i and $self->{'nodup'} or 0), $pk_col); 575 $output .= $T . _tag_it('tr',$attribs,$cdata) . $N; 576 } 577 578 # build the subtotal row if applicable 579 if (my $subtotals = shift @{$self->{'sub_totals'}}) { 580 $cdata = $self->_build_body_subtotal($subtotals); 581 $output .= $T . _tag_it('tr',$attribs,$cdata) . $N; 582 } 583 584 return $output; 585} 586 587sub _build_body_row { 588 my ($self,$row,$nodup,$pk) = @_; 589 590 my $group = $self->{'group'}; 591 my $index = $self->_lookup_index($group) if $group; 592 my $output = $N; 593 594 $self->{'current_row'} = $pk; 595 596 for (0..$#$row) { 597 my $name = $self->_lookup_name($_); 598 my $attribs = _merge_attribs( 599 $self->{$name}->{'td'} || $self->{'body'}->{'td'}, 600 $self->{'global'}->{'td'} || $self->{'body'}->{'td'}, 601 ); 602 603 # suppress warnings AND keep 0 from becoming 604 $row->[$_] = '' unless defined($row->[$_]); 605 606 # bug 21761 "Special XML characters should be expressed as entities" 607 $row->[$_] = $self->_xml_encode( $row->[$_] ) if $self->{'encode_cells'}; 608 609 my $cdata = ($row->[$_] =~ /^\s+$/) 610 ? $self->{'null_value'} 611 : $row->[$_] 612 ; 613 614 $self->{'current_col'} = $name; 615 616 $cdata = ($nodup and $index == $_) 617 ? $self->{'nodup'} 618 : _map_it($self->{'map_cell'}->{$name},$cdata) 619 ; 620 621 $output .= $T.$T . _tag_it('td', $attribs, $cdata) . $N; 622 } 623 return $output . $T; 624} 625 626sub _build_body_subtotal { 627 my ($self,$row) = @_; 628 my $output = $N; 629 630 return '' unless $row; 631 632 for (0..$#$row) { 633 my $name = $self->_lookup_name($_); 634 my $sum = ($row->[$_]); 635 my $attribs = _merge_attribs( 636 $self->{$name}->{'th'} || $self->{'body'}->{'th'}, 637 $self->{'global'}->{'th'} || $self->{'body'}->{'th'}, 638 ); 639 640 # use sprintf if mask was supplied 641 if ($self->{'subtotals_mask'} and defined $sum) { 642 $sum = sprintf($self->{'subtotals_mask'},$sum); 643 } 644 else { 645 $sum = (defined $sum) ? $sum : $self->{'null_value'}; 646 } 647 648 $output .= $T.$T . _tag_it('th', $attribs, $sum) . $N; 649 } 650 return $output . $T; 651} 652 653sub _build_foot { 654 my ($self) = @_; 655 656 my $tr_attribs = _merge_attribs( 657 # notice that foot is 1st and global 2nd - different than rest 658 $self->{'foot'}->{'tr'}, $self->{'global'}->{'tr'} 659 ); 660 my $tr_cdata = $self->_build_foot_row(); 661 662 my $attribs = $self->{'foot'}->{'tfoot'} || $self->{'global'}->{'tfoot'}; 663 my $cdata = $N.$T . _tag_it('tr', $tr_attribs, $tr_cdata) . $N.$T; 664 665 return $T . _tag_it('tfoot',$attribs,$cdata) . $N; 666} 667 668sub _build_foot_row { 669 my ($self) = @_; 670 671 my $output = $N; 672 my $row = $self->{'totals'}; 673 674 for (0..$#$row) { 675 my $name = $self->_lookup_name($_); 676 my $attribs = _merge_attribs( 677 $self->{$name}->{'th'} || $self->{'foot'}->{'th'}, 678 $self->{'global'}->{'th'} || $self->{'foot'}->{'th'}, 679 ); 680 my $sum = ($row->[$_]); 681 682 # use sprintf if mask was supplied 683 if ($self->{'totals_mask'} and defined $sum) { 684 $sum = sprintf($self->{'totals_mask'},$sum) 685 } 686 else { 687 $sum = defined $sum ? $sum : $self->{'null_value'}; 688 } 689 690 $output .= $T.$T . _tag_it('th', $attribs, $sum) . $N; 691 } 692 return $output . $T; 693} 694 695# builds a tag and it's enclosed data 696sub _tag_it { 697 my ($name,$attribs,$cdata) = @_; 698 my $text = "<\L$name\E"; 699 700 # build the attributes if any - skip blank vals 701 for my $k (sort keys %{$attribs}) { 702 my $v = $attribs->{$k}; 703 if (ref $v eq 'HASH') { 704 $v = join('; ', map { 705 my $attrib = $_; 706 my $value = (ref $v->{$_} eq 'ARRAY') 707 ? _rotate($v->{$_}) 708 : $v->{$_}; 709 join(': ',$attrib,$value||''); 710 } sort keys %$v) . ';'; 711 } 712 $v = _rotate($v) if (ref $v eq 'ARRAY'); 713 $text .= qq| \L$k\E="$v"| unless $v =~ /^$/; 714 } 715 $text .= (defined $cdata) ? ">$cdata</\L$name\E>" : '/>'; 716} 717 718# used by map_cell() and map_head() 719sub _map_it { 720 my ($sub,$datum) = @_; 721 return $datum unless $sub; 722 return $datum = $sub->($datum); 723} 724 725# used by calc_totals() and calc_subtotals() 726sub _total_chunk { 727 my ($self,$chunk,$indexes) = @_; 728 my %totals; 729 730 foreach my $row (@$chunk) { 731 foreach (@$indexes) { 732 $totals{$_} += $row->[$_] if $row->[$_] =~ /^[-0-9\.]+$/; 733 } 734 } 735 736 return [ map { defined $totals{$_} ? $totals{$_} : undef } (0 .. $self->get_col_count() - 1) ]; 737} 738 739# uses %ESCAPES to convert the '4 Horsemen' of XML 740# big thanks to Matt Sergeant 741sub _xml_encode { 742 my ($self,$str) = @_; 743 $str =~ s/([&<>"])/$ESCAPES{$1}/ge; 744 return $str; 745} 746 747# returns value of and moves first element to last 748sub _rotate { 749 my $ref = shift; 750 my $next = shift @$ref; 751 push @$ref, $next; 752 return $next; 753} 754 755# always returns an array ref 756sub _refinate { 757 my ($self,$ref) = @_; 758 $ref = undef if ref($ref) eq 'ARRAY' && scalar( @$ref ) < 1; 759 $ref = [@{$self->{'fields_arry'}}] unless defined $ref; 760 $ref = [$ref] unless ref $ref eq 'ARRAY'; 761 return [map {$_ =~ /^\d+$/ ? $self->_lookup_name($_) || $_ : $_} @$ref]; 762} 763 764sub _merge_attribs { 765 my ($hash1,$hash2) = @_; 766 767 return $hash1 unless $hash2; 768 return $hash2 unless $hash1; 769 770 return {%$hash2,%$hash1}; 771} 772 773sub _lookup_name { 774 my ($self,$index) = @_; 775 return $self->{'fields_arry'}->[$index]; 776} 777 778sub _lookup_index { 779 my ($self,$name) = @_; 780 return $self->{'fields_hash'}->{$name}; 781} 782 783sub _reset_fields_hash { 784 my $self = shift; 785 my $i = 0; 786 $self->{fields_hash} = { map { $_ => $i++ } @{$self->{fields_arry}} }; 787} 788 789# assigns a non-DBI supplied data table (2D array ref) 790sub _do_black_magic { 791 my ($self,$ref,$headers) = @_; 792 croak "bad data" unless ref( $ref->[0] ) eq 'ARRAY'; 793 $self->{'fields_arry'} = $headers ? [@$headers] : [ @{ shift @$ref } ]; 794 $self->{'fields_hash'} = $self->_reset_fields_hash(); 795 $self->{'rows'} = $ref; 796} 797 798# disconnect database handle if i created it 799sub DESTROY { 800 my ($self) = @_; 801 unless ($self->{'keep_alive'}) { 802 $self->{'dbh'}->disconnect if defined $self->{'dbh'}; 803 } 804} 805 8061; 807__END__ 808 809=head1 NAME 810 811DBIx::XHTML_Table - SQL query result set to XHTML table. 812 813=head1 SYNOPSIS 814 815 use DBIx::XHTML_Table; 816 817 # database credentials - fill in the blanks 818 my ($data_source,$usr,$pass) = (); 819 820 my $table = DBIx::XHTML_Table->new($data_source,$usr,$pass); 821 822 $table->exec_query(" 823 select foo from bar 824 where baz='qux' 825 order by foo 826 "); 827 828 print $table->output(); 829 830 # stackable method calls: 831 print DBIx::XHTML_Table 832 ->new($data_source,$usr,$pass) 833 ->exec_query('select foo,baz from bar') 834 ->output(); 835 836 # and much more - read on ... 837 838=head1 DESCRIPTION 839 840B<DBIx::XHTML_Table> is a DBI extension that creates an HTML 841table from a database query result set. It was created to fill 842the gap between fetching data from a database and transforming 843that data into a web browser renderable table. DBIx::XHTML_Table is 844intended for programmers who want the responsibility of presenting 845(decorating) data, easily. This module is meant to be used in situations 846where the concern for presentation and logic seperation is overkill. 847Providing logic or editable data is beyond the scope of this module, 848but it is capable of doing such. 849 850=head1 CODE FREEZE 851 852For the most part, no new functionality will be added to this module. 853Only bug fixes and documentation corrections/additions. All new efforts 854will be directed towards the rewrite of this distribution, B<DBIx::HTML>. 855 856This distribution features a more flexible interface with fewer methods and 857logically named argument parameters. At the core is an HTML attribute generator: 858 859=over 4 860 861=item * L<Tie::Hash::Attribute> 862 863=back 864 865Which is used by an HTML tag generator: 866 867=over 4 868 869=item * L<HTML::AutoTag> 870 871=back 872 873Which is used by an HTML table generator: 874 875=over 4 876 877=item * L<Spreadsheet::HTML> 878 879=back 880 881Which is finally wrapped by a DBI extension: 882 883=over 4 884 885=item * L<DBIx::HTML> 886 887=back 888 889=head1 WEBSITE 890 891More documentation (tutorial, cookbook, FAQ, etc.) can be found at 892 893 http://www.unlocalhost.com/XHTML_Table/ 894 895=head1 GITHUB 896 897 https://github.com/jeffa/DBIx-XHTML_Table 898 899=head1 CONSTRUCTOR 900 901=over 4 902 903=item B<style_1> 904 905 $obj_ref = new DBIx::XHTML_Table(@credentials[,$attribs]) 906 907Note - all optional arguments are denoted inside brackets. 908 909The constructor will simply pass the credentials to the DBI::connect 910method - read the DBI documentation as well as the docs for your 911corresponding DBI driver module (DBD::Oracle, DBD::Sybase, 912DBD::mysql, etc). 913 914 # MySQL example 915 my $table = DBIx::XHTML_Table->new( 916 'DBI:mysql:database:host', # datasource 917 'user', # user name 918 'password', # user password 919 ) or die "couldn't connect to database"; 920 921The last argument, $attribs, is an optional hash reference 922and should not be confused with the DBI::connect method's 923similar 'attributes' hash reference.' 924 925 # valid example for last argument 926 my $attribs = { 927 table => { 928 border => 1, 929 cellspacing => 0, 930 rules => 'groups', 931 }, 932 caption => 'Example', 933 td => { 934 style => 'text-align: right', 935 }, 936 }; 937 938 my $table = DBIx::XHTML_Table->new( 939 $data_source,$user,$pass,$attribs 940 ) or die "couldn't connect to database"; 941 942But it is still experimental and unpleasantly limiting. 943The purpose of $table_attribs is to bypass having to 944call modify() multiple times. However, if you find 945yourself calling modify() more than 4 or 5 times, 946then DBIx::XHTML_Table might be the wrong tool. I recommend 947HTML::Template or Template-Toolkit, both available at CPAN. 948 949=item B<style_2> 950 951 $obj_ref = new DBIx::XHTML_Table($DBH[,$attribs]) 952 953The first style will result in the database handle being created 954and destroyed 'behind the scenes'. If you need to keep the database 955connection open after the XHTML_Table object is destroyed, then 956create one yourself and pass it to the constructor: 957 958 my $dbh = DBI->connect( 959 $data_source,$usr,$passwd, 960 {RaiseError => 1}, 961 ); 962 963 my $table = DBIx::XHTML_Table->new($dbh); 964 # do stuff 965 $dbh->disconnect; 966 967You can also use any class that isa() DBI::db object, such 968as Apache::DBI or DBIx::Password objects: 969 970 my $dbh = DBIx::Password->connect($user); 971 my $table = DBIx::XHTML_Table->new($dbh); 972 973=item B<style_3> 974 975 $obj_ref = new DBIx::XHTML_Table($rows[,$headers]) 976 977The final style allows you to bypass a database altogether if need 978be. Simply pass a LoL (list of lists) such as the one passed back 979from the DBI method C<selectall_arrayref()>. The first row will be 980treated as the table heading. You are responsible for supplying the 981column names. Here is one way to create a table after modifying the 982result set from a database query: 983 984 my $dbh = DBI->connect($dsource,$usr,$passwd); 985 my $sth = $dbh->prepare('select foo,baz from bar'); 986 $sth->execute(); 987 988 # order is essential here 989 my $headers = $sth->{'NAME'}; 990 my $rows = $sth->fetchall_arrayref(); 991 992 # do something to $rows 993 994 my $table = DBIx::XHTML_Table->new($rows,$headers); 995 996If $headers is not supplied, then the first row from the 997first argument will be shifted off and used instead. 998While obtaining the data from a database is the entire 999point of this module, there is nothing stopping you from 1000simply hard coding it: 1001 1002 my $rows = [ 1003 [ qw(Head1 Head2 Head3) ], 1004 [ qw(foo bar baz) ], 1005 [ qw(one two three) ], 1006 [ qw(un deux trois) ] 1007 ]; 1008 1009 my $table = DBIx::XHTML_Table->new($rows); 1010 1011And that is why $headers is optional. 1012 1013=back 1014 1015=head1 OBJECT METHODS 1016 1017=over 4 1018 1019=item B<exec_query> 1020 1021 $table->exec_query($sql[,$bind_vars]) 1022 1023Pass the query off to the database with hopes that data will be 1024returned. The first argument is scalar that contains the SQL 1025code, the optional second argument can either be a scalar for one 1026bind variable or an array reference for multiple bind vars: 1027 1028 $table->exec_query(' 1029 select bar,baz from foo 1030 where bar = ? 1031 and baz = ? 1032 ',[$foo,$bar]); 1033 1034exec_query() also accepts a prepared DBI::st handle: 1035 1036 my $sth = $dbh->prepare(' 1037 select bar,baz from foo 1038 where bar = ? 1039 and baz = ? 1040 '); 1041 1042 $table->exec_query($sth,[$foo,$bar]); 1043 1044Consult the DBI documentation for more details on bind vars. 1045 1046After the query successfully executes, the results will be 1047stored interally as a 2-D array. The XHTML table tags will 1048not be generated until the output() method is invoked. 1049 1050=item B<output> 1051 1052 $scalar = $table->output([$attribs]) 1053 1054Renders and returns the XHTML table. The only argument is 1055an optional hash reference that can contain any combination 1056of the following keys, set to a true value. Most of the 1057time you will not want to use this argument, but there are 1058three times when you will: 1059 1060 # 1 - do not display a thead section 1061 print $table->output({ no_head => 1 }); 1062 1063This will cause the thead section to be suppressed, but 1064not the caption if you set one. The 1065column foots can be suppressed by not calculating totals, and 1066the body can be suppressed by an appropriate SQL query. The 1067caption and colgroup cols can be suppressed by not modifying 1068them. The column titles are the only section that has to be 1069specifically 'told' not to generate, and this is where you do that. 1070 1071 # 2 - do not format the headers with ucfirst 1072 print $table->output({ no_ucfirst => 1 }); 1073 1074This allows you to bypass the automatic upper casing of the first 1075word in each of the column names in the table header. If you just 1076wish to have them displayed as all lower case, then use this 1077option, if you wish to use some other case, use map_head() 1078 1079 # 3 - 'squash' the output HTML table 1080 print $table->output({ no_indent => 1 }); 1081 1082This will result in the output having no text aligning whitespace, 1083that is no newline(\n) and tab(\t) characters. Useful for squashing 1084the total number of bytes resulting from large return sets. 1085 1086You can combine these attributes, but there is no reason to use 1087no_ucfirst in conjunction with no_head. 1088 1089Note: versions prior to 0.98 used a two argument form: 1090 1091 $scalar = $table->output([$sans_title,$sans_whitespace]) 1092 1093You can still use this form to suppress titles and whitespace, 1094but warnings will be generated. 1095 1096HTML encoding of table cells is turned off by default, but can 1097be turned on via: 1098 1099 $table->{encode_cells} = 1; 1100 1101=item B<get_table> 1102 1103 $scalar = $table->get_table([ {attribs} ]) 1104 1105Deprecated - use output() instead. 1106 1107=item B<modify> 1108 1109 $table->modify($tag,$attribs[,$cols]) 1110 1111This method will store a 'memo' of what attributes you have assigned 1112to various tags within the table. When the table is rendered, these 1113memos will be used to create attributes. The first argument is the 1114name of the tag you wish to modify the attributes of. You can supply 1115any tag name you want without fear of halting the program, but the 1116only tag names that are handled are <table> <caption> <thead> <tfoot> 1117<tbody> <colgroup> <col> <tr> <th> and <td>. The tag name will be 1118converted to lowercase, so you can practice safe case insensitivity. 1119 1120The next argument is a reference to a hash that contains the 1121attributes you wish to apply to the tag. For example, this 1122sets the attributes for the <table> tag: 1123 1124 $table->modify('table',{ 1125 border => '2', 1126 width => '100%' 1127 }); 1128 1129 # a more Perl-ish way 1130 $table->modify(table => { 1131 border => 2, 1132 width => '100%', 1133 }); 1134 1135 # you can even specify CSS styles 1136 $table->modify(td => { 1137 style => 'color: blue; text-align: center', 1138 }); 1139 1140 # there is more than one way to do it 1141 $table->modify(td => { 1142 style => { 1143 color => 'blue', 1144 'text-align' => 'center', 1145 } 1146 }); 1147 1148Each key in the hash ref will be lower-cased, and each value will be 1149surrounded in quotes. Note that typos in attribute names will not 1150be caught by this module. Any attribute can be used, valid XHTML 1151attributes tend be more effective. And yes, JavaScript works too. 1152 1153You can even use an array reference as the key values: 1154 1155 $table->modify(td => { 1156 bgcolor => [qw(red purple blue green yellow orange)], 1157 }), 1158 1159As the table is rendered row by row, column by column, the 1160elements of the array reference will be 'rotated' 1161across the <td> tags, causing different effects depending 1162upon the number of elements supplied and the number of 1163columns and rows in the table. The following is the preferred 1164XHTML way with CSS styles: 1165 1166 $table->modify(th => { 1167 style => { 1168 background => ['#cccccc','#aaaaaa'], 1169 } 1170 }); 1171 1172See the set_row_color() and set_col_color() methods for more info. 1173 1174The last argument to modify() is optional and can either be a scalar 1175representing a single column or area, or an array reference 1176containing multilple columns or areas. The columns will be 1177the corresponding names of the columns from the SQL query, 1178or their anticipated index number, starting at zero. 1179The areas are one of three values: HEAD, BODY, or FOOT. 1180The columns and areas you specify are case insensitive. 1181 1182 # just modify the titles 1183 $table->modify(th => { 1184 bgcolor => '#bacaba', 1185 }, 'head'); 1186 1187 # only <td> tags in column FOO will be set 1188 $table->modify(td => { 1189 style => 'text-align: center' 1190 },'foo'); 1191 1192 # <td> tags for the second and third columns (indexes 1 and 2) 1193 $table->modify(td => { 1194 style => 'text-align: right' 1195 },[1,2]); 1196 1197You cannot currently mix areas and columns in the same method call. 1198That is, you cannot set a specific column in the 'head' area, 1199but not the 'body' area. This _might_ change in the future, but 1200such specific needs are a symptom of needing a more powerful tool. 1201 1202As of Version 1.10, multiple calls to modfiy() are inheritable. 1203For example, if you set an attribute for all <td> tags and set 1204another attribute for a specific column, that specific column 1205will inherit both attributes: 1206 1207 $table->modify(td => {foo => 'bar'}); 1208 $table->modify(td => {baz => 'qux'},'Salary'); 1209 1210In the preceding code, all <td> tags will have the attribute 1211'foo = "bar"', and the <td> tags for the 'Salary' column will 1212have the attributes 'foo = "bar"' and 'baz = "qux"'. Should 1213you not this behavior, you can 'erase' the unwanted attribute 1214by setting the value of an attribute to the empty string: 1215 1216 $table->modify(td => {foo => 'bar'}); 1217 $table->modify(td => {foo =>'', baz => 'qux'},'Salary'); 1218 1219Note the use of the empty string and not undef or 0. Setting 1220the value to undef will work, but will issue a warning if you 1221have warnings turned on. Setting the value to 0 will set the 1222value of the attribute to 0, not remove it. 1223 1224A final caveat is setting the <caption> tag. This one breaks 1225the signature convention: 1226 1227 $table->modify(tag => $value, $attrib); 1228 1229Since there is only one <caption> allowed in an XHTML table, 1230there is no reason to bind it to a column or an area: 1231 1232 # with attributes 1233 $table->modify( 1234 caption => 'A Table Of Contents', 1235 { align => 'bottom' } 1236 ); 1237 1238 # without attributes 1239 $table->modify(caption => 'A Table Of Contents'); 1240 1241The only tag that cannot be modified by modify() is the <col> 1242tag. Use add_col_tag() instead. 1243 1244=item B<modify_tag> 1245 1246 $table->modify_tag($tag,$attribs[,$cols]) 1247 1248Deprecated, use the easier to type modify() instead. 1249 1250=item B<add_col_tag> 1251 1252 $table->add_col_tag($cols) 1253 1254Add a new <col> tag and attributes. The only argument is reference 1255to a hash that contains the attributes for this <col> tag. Multiple 1256<col> tags require multiple calls to this method. The <colgroup> tag 1257pair will be automatically generated if at least one <col> tag is 1258added. 1259 1260Advice: use <col> and <colgroup> tags wisely, don't do this: 1261 1262 # bad 1263 for (0..39) { 1264 $table->add_col_tag({ 1265 foo => 'bar', 1266 }); 1267 } 1268 1269When this will suffice: 1270 1271 # good 1272 $table->modify(colgroup => { 1273 span => 40, 1274 foo => 'bar', 1275 }); 1276 1277You should also consider using <col> tags to set the attributes 1278of <td> and <th> instead of the <td> and <th> tags themselves, 1279especially if it is for the entire table. Notice the use of the 1280get_col_count() method in this example to span the entire table: 1281 1282 $table->add_col_tag({ 1283 span => $table->get_col_count(), 1284 style => 'text-align: center', 1285 }); 1286 1287=item B<map_cell> 1288 1289 $table->map_cell($subroutine[,$cols]) 1290 1291Map a supplied subroutine to all the <td> tag's cdata for 1292the specified columns. The first argument is a reference to a 1293subroutine. This subroutine should shift off a single scalar at 1294the beginning, munge it in some fasion, and then return it. 1295The second argument is the column (scalar) or columns (reference 1296to a list of scalars) to apply this subroutine to. Example: 1297 1298 # uppercase the data in column DEPARTMENT 1299 $table->map_cell( sub { return uc shift }, 'department'); 1300 1301 # uppercase the data in the fifth column 1302 $table->map_cell( sub { return uc shift }, 4); 1303 1304One temptation that needs to be addressed is using this method to 1305color the cdata inside a <td> tag pair. For example: 1306 1307 # don't be tempted to do this 1308 $table->map_cell(sub { 1309 return qq|<font color="red">| . shift . qq|</font>|; 1310 }, [qw(first_name last_name)]); 1311 1312 # when CSS styles will work 1313 $table->modify(td => { 1314 style => 'color: red', 1315 }, [qw(first_name last_name)]); 1316 1317Note that the get_current_row() and get_current_col() 1318can be used inside the sub reference. See set_pk() below 1319for an example. 1320 1321All columns are used if none are specified, and you can 1322specify index number(s) as well as name(s). Also, 1323exec_query() must be called and data must be returned 1324from the database prior to calling this method, otherwise 1325the call back will be ignored and a warning will be generated. 1326This is true for map_head() as well. 1327 1328=item B<map_col> 1329 1330 $table->map_col($subroutine[,$cols]) 1331 1332Deprecated - use map_cell() instead. 1333 1334=item B<map_head> 1335 1336 $table->map_head($subroutine[,$cols]) 1337 1338Just like map_cell() except it modifies only column headers, 1339i.e. the <th> data located inside the <thead> section. The 1340immediate application is to change capitalization of the column 1341headers, which are defaulted to ucfirst: 1342 1343 $table->map_head(sub { uc shift }); 1344 1345Instead of using map_head() to lower case the column headers, 1346just specify that you don't want default capitalization with 1347output(): 1348 1349 $table->output({ no_ucfirst => 1 }); 1350 1351=item B<set_row_colors> 1352 1353 $table->set_row_colors($colors[,$attrib_name]); 1354 1355This method will produce horizontal stripes. 1356This first argument is an array reference that contains 1357the colors to use. Each row will get a color from the 1358list - when the last color in the list is reached, 1359then the rotation will start over at the beginning. 1360This will continue until all <tr> tags have been 1361generated. If you don't supply an array reference with 1362at least 2 colors then this method will return without 1363telling you. 1364 1365set_row_colors() by default will use CSS styles to 1366color the rows. The optional second argument is a single 1367scalar that can be used to specify another attribute 1368instead of the CSS style 'color'. For example, you 1369could use 'class' or even deprecated HTML attributes 1370such as 'bgcolor' or 'width'. 1371 1372This method is just a more convenient way to do the 1373same thing with the modify() modify. 1374 1375See http://www.unlocalhost.com/XHTML_Table/cookbook.html#5 1376for more information on coloring the table. 1377 1378=item B<set_col_colors> 1379 1380 $table->set_col_colors($colors[,$attrib_name]); 1381 1382This method will produce vertical stripes. 1383The first argument is an array reference to arrays just 1384like set_row_colors(). 1385 1386Unlike set_row_colors() however, this module is more 1387than just a convenient way to do the same with the modify() method. 1388The problem arises when you supply an odd number of 1389colors for an even number of columns, vice versa, or 1390both odd. The result will be a checkerboard. Not very 1391readable for anything except board games. By using 1392set_col_colors() instead, the result will always be 1393vertical stripes. 1394 1395set_col_colors() by default will use CSS styles to 1396color the rows. The optional second argument is a single 1397scalar that can be used to specify another attribute 1398instead of the CSS style 'color'. For example, you 1399could use 'class' or even deprecated HTML attributes 1400such as 'bgcolor' or 'width'. 1401 1402See http://www.unlocalhost.com/XHTML_Table/cookbook.html#5 1403for more information on coloring the table. 1404 1405=item B<set_null_value> 1406 1407 $table->set_null_value($new_null_value) 1408 1409Change the default null_value ( ) to something else. 1410Any column that is undefined will have this value 1411substituted instead. 1412 1413=item B<set_pk> 1414 1415 $table->set_pk([$primary_key]); 1416 1417This method must be called before exec_query() in order to work! 1418 1419Note that the single argument to this method, $primary_key, is optional. 1420If you do not specify a primary key, then 'id' will be used. 1421 1422This is highly specialized method - the need is when you want to select 1423the primary key along with the columns you want to display, but you 1424don't want to display it as well. The value will be accessible via the 1425get_current_row() method. This is useful as a a callback via the map_cell() 1426method. Consider the following: 1427 1428 $table->map_cell(sub { 1429 my $datum = shift; 1430 my $row = $table->get_current_row(); 1431 my $col = $table->get_current_col(); 1432 return qq|<input type="text" name="$row:$col" value="$datum">|; 1433 }); 1434 1435This will render a "poor man's" spreadsheet, provided that set_pk() was 1436called with the proper primary key before exec_query() was called. 1437Now each input has a name that can be split to reveal which row and 1438column the value belongs to. 1439 1440Big thanks to Jim Cromie for the idea. 1441 1442=item B<set_group> 1443 1444 $table->set_group($column[,$no_dups,$replace_with]) 1445 1446Assign one column as the main column. Every time a new row is 1447encountered for this column, a <tbody> tag is written. An optional 1448second argument that contains a defined, non-zero value will cause duplicates 1449to be permanantly eliminated for this row. An optional third argument 1450specifies what value to replace for duplicates, default is 1451 1452 # replace duplicates with the global 'null_value' 1453 $table->set_group('Branch',1); 1454 1455 # replace duplicates with a new value 1456 $table->set_group('Branch',1,'----'); 1457 1458 # or in a more Perl-ish way 1459 $table->set_group('Branch',nodups=>'----'); 1460 1461Don't assign a column that has a different value each row, choose 1462one that is a super class to the rest of the data, for example, 1463pick album over song, since an album consists of songs. 1464 1465So, what's it good for? If you set a group (via the set_group() method) 1466and supply the following: 1467 1468 # well, and you are viewing in IE... 1469 $table->modify(table => { 1470 cellspacing => 0, 1471 rules => 'groups', 1472 }); 1473 1474then horizontal lines will only appear at the point where the 'grouped' 1475rows change. This had to be implemented in the past with <table>'s 1476inside of <table>'s. Much nicer! Add this for a nice coloring trick: 1477 1478 # this works with or without setting a group, by the way 1479 $table->modify(tbody => { 1480 bgcolor => [qw(insert rotating colors here)], 1481 }); 1482 1483=item B<calc_totals> 1484 1485 $table->calc_totals([$cols,$mask]) 1486 1487Computes totals for specified columns. The first argument is the column 1488or columns to sum, again a scalar or array reference is the requirement. 1489If $cols is not specified, all columns will be totaled. Non-numbers will 1490be ignored, negatives and floating points are supported, but you have to 1491supply an appropriate sprintf mask, which is the optional second argument, 1492in order for the sum to be correctly formatted. See the sprintf docs 1493for further details. 1494 1495=item B<calc_subtotals> 1496 1497 $table->calc_subtotals([$cols,$mask]) 1498 1499Computes subtotals for specified columns. It is mandatory that you 1500first specify a group via set_group() before you call this method. 1501Each subtotal is tallied from the rows that have the same value 1502in the column that you specified to be the group. At this point, only 1503one subtotal row per group can be calculated and displayed. 1504 1505=item B<get_col_count> 1506 1507 $scalar = $table->get_col_count() 1508 1509Returns the number of columns in the table. 1510 1511=item B<get_row_count> 1512 1513 $scalar = $table->get_row_count() 1514 1515Returns the numbers of body rows in the table. 1516 1517=item B<get_current_row> 1518 1519 $scalar = $table->get_current_row() 1520 1521Returns the value of the primary key for the current row being processed. 1522This method is only meaningful inside a map_cell() callback; if you access 1523it otherwise, you will either receive undef or the value of the primary 1524key of the last row of data. 1525 1526=item B<get_current_col> 1527 1528 $scalar = $table->get_current_col() 1529 1530Returns the name of the column being processed. 1531This method is only meaningful inside a map_cell() callback; if you access 1532it otherwise, you will either receive undef or the the name of the last 1533column specified in your SQL statement. 1534 1535=item B<add_cols> 1536 1537 $table->add_cols( 1538 { header => '', data => [], before => '' }, { ... }, ... 1539 ); 1540 1541Going against the philosophy of only select what you need from the database, 1542this sub allows you to remove whole columns. 'header' is the name of the new 1543column, you will have to ucfirst yourself. It is up to you to ensure that 1544that the size of 'data' is the same as the number of rows in the original 1545data set. 'before' can be an index or the name of the column. For example, 1546to add a new column to the beginning: 1547 1548 $table->add_cols({name=>'New', data=>\@rows, before => 0}); 1549 1550add a new column to the end: 1551 1552 $table->add_cols({name=>'New', data=>\@rows}); 1553 1554or somewhere in the middle: 1555 1556 $table->add_cols({name=>'New', data=>\@rows}, before => 'age'}); 1557 1558or combine all three into one call: 1559 1560 $table->add_cols( 1561 {name=>'Foo', data=>\@rows, before => 0}, 1562 {name=>'Bar', data=>\@rows}, 1563 {name=>'Baz', data=>\@rows}, before => 'Bar'}, 1564 ); 1565 1566=item B<drop_cols> 1567 1568 $table->drop_cols([qw(foo bar 5)]; 1569 1570Like add_cols, drop_cols goes against said 'philosophy', but it is here for 1571the sake of TIMTWOTDI. Simply pass it an array ref that contains either the 1572name or positions of the columns you want to drop. 1573 1574=item B<new> 1575 1576Things with the stuff. 1577 1578=item B<reset> 1579 1580Stuff with the things. 1581 1582=back 1583 1584=head1 TAG REFERENCE 1585 1586 TAG CREATION BELONGS TO AREA 1587+------------+----------+--------------------+ 1588| <table> | auto | ---- | 1589| <caption> | manual | ---- | 1590| <colgroup> | both | ---- | 1591| <col>* | manual | ---- | 1592| <thead> | auto | head | 1593| <tbody> | auto | body | 1594| <tfoot> | auto | foot | 1595| <tr> | auto | head,body,foot | 1596| <td> | auto | body | 1597| <th> | auto | head,body,foot | 1598+------------+-------------------------------+ 1599 1600 * All tags use modify() to set attributes 1601 except <col>, which uses add_col_tag() instead 1602 1603=head1 BUGS 1604 1605If you have found a bug, typo, etc. please visit Best Practical Solution's 1606CPAN bug tracker at http://rt.cpan.org: 1607 1608E<lt>http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-XHTML_TableE<gt> 1609 1610or send mail to E<lt>bug-DBIx-XHTML_Table#rt.cpan.orgE<gt> 1611 1612(you got this far ... you can figure out how to make that 1613a valid address ... and note that i won't respond to bugs 1614sent to my personal address any longer) 1615 1616=head1 ISSUES 1617 1618=over 4 1619 1620=item Problems with 'SELECT *' 1621 1622Users are recommended to avoid 'select *' and instead 1623specify the names of the columns. Problems have been reported 1624using 'select *' with SQLServer7 will cause certain 'text' type 1625columns not to display. I have not experienced this problem 1626personally, and tests with Oracle and MySQL show that they are not 1627affected by this. SQLServer7 users, please help me confirm this. :) 1628 1629=item Not specifying <body> tag in CGI scripts 1630 1631I anticipate this module to be used by CGI scripts, and when 1632writing my own 'throw-away' scripts, I noticed that Netscape 4 1633will not display a table that contains XHTML tags IF a <body> 1634tag is NOT found. Be sure and print one out. 1635 1636=back 1637 1638=head1 CREDITS 1639 1640Briac [OeufMayo] PilprE<eacute> for the name. 1641 1642Mark [extremely] Mills for patches and suggestions. 1643 1644Jim Cromie for presenting the whole spreadsheet idea. 1645 1646Stephen Nelson for documentation/code corrections. 1647 1648Matt Sergeant for DBIx::XML_RDB. 1649 1650Aaron [trs80] Johnson for convincing me into writing add and drop cols. 1651 1652Richard Piacentini and Tim Alexander for recommending DBIx::Password and Apache::DBI compatability and Slaven Rezic for recommending using UNIVERSAL::isa(). 1653 1654Perl Monks for the education. 1655 1656=head1 SEE ALSO 1657 1658DBI 1659 1660=head1 AUTHOR 1661 1662Jeff Anderson 1663 1664=head1 COPYRIGHT 1665 1666Copyright 2017 Jeff Anderson. 1667 1668This program is free software; you can redistribute it and/or modify it 1669under the terms of the the Artistic License (2.0). You may obtain a 1670copy of the full license at: 1671 1672L<http://www.perlfoundation.org/artistic_license_2_0> 1673 1674Any use, modification, and distribution of the Standard or Modified 1675Versions is governed by this Artistic License. By using, modifying or 1676distributing the Package, you accept this license. Do not use, modify, 1677or distribute the Package, if you do not accept this license. 1678 1679If your Modified Version has been derived from a Modified Version made 1680by someone other than you, you are nevertheless required to ensure that 1681your Modified Version complies with the requirements of this license. 1682 1683This license does not grant you the right to use any trademark, service 1684mark, tradename, or logo of the Copyright Holder. 1685 1686This license includes the non-exclusive, worldwide, free-of-charge 1687patent license to make, have made, use, offer to sell, sell, import and 1688otherwise transfer the Package with respect to any patent claims 1689licensable by the Copyright Holder that are necessarily infringed by the 1690Package. If you institute patent litigation (including a cross-claim or 1691counterclaim) against any party alleging that the Package constitutes 1692direct or contributory patent infringement, then this Artistic License 1693to you shall terminate on the date that such litigation is filed. 1694 1695Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER 1696AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. 1697THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 1698PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY 1699YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR 1700CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR 1701CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, 1702EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 1703 1704=cut 1705