view release on metacpan or  search on metacpan

lib/DBIx/XHTML_Table.pm  view on Meta::CPAN

        my ($name,$data,$pos) = @$_{(qw(name data before))};
        my $max_pos = $self->get_col_count();

        $pos  = $self->_lookup_index(ucfirst $pos || '') || $max_pos unless defined $pos && $pos =~ /^\d+$/;
        $pos  = $max_pos if $pos > $max_pos;
        $data = [$data] unless ref $data eq 'ARRAY';

        splice(@{$self->{'fields_arry'}},$pos,0,$name);
        $self->_reset_fields_hash();
        splice(@$_,$pos,0,_rotate($data)) for (@{$self->{rows}});
    }

    return $self;
}

sub drop_cols {
    my ($self,$cols) = @_;
    $cols = $self->_refinate($cols);

    foreach my $col (@$cols) {
        my $index = delete $self->{'fields_hash'}->{$col};
        splice(@{$self->{'fields_arry'}},$index,1);
        $self->_reset_fields_hash();
        splice(@$_,$index,1) for (@{$self->{'rows'}});
    }

    return $self;
}

###################### DEPRECATED ##################################

sub get_table { 
    carp "get_table() is deprecated. Use output() instead";
    output(@_);
}

sub modify_tag {
    carp "modify_tag() is deprecated. Use modify() instead";
    modify(@_);
}

sub map_col { 
    carp "map_col() is deprecated. Use map_cell() instead";
    map_cell(@_);
}

#################### UNDER THE HOOD ################################

# repeat: it only looks complicated

sub _build_table {
    my ($self)  = @_;
    my $attribs = $self->{'global'}->{'table'};

    my ($head,$body,$foot);
    $head = $self->_build_head;
    $body = $self->{'rows'}   ?  $self->_build_body : '';
    $foot = $self->{'totals'} ?  $self->_build_foot : '';

    # w3c says tfoot comes before tbody ...
    my $cdata = $head . $foot . $body;

    return _tag_it('table', $attribs, $cdata) . $N;
}

sub _build_head {
    my ($self) = @_;
    my ($attribs,$cdata,$caption);
    my $output = '';

    # build the <caption> tag if applicable
    if ($caption = $self->{'global'}->{'caption'}) {
        $attribs = $self->{'global'}->{'caption_attribs'};
        $cdata   = $self->{'encode_cells'} ? $self->_xml_encode($caption) : $caption;
        $output .= $N.$T . _tag_it('caption', $attribs, $cdata);
    }

    # build the <colgroup> tags if applicable
    if ($attribs = $self->{'global'}->{'colgroup'}) {
        $cdata   = $self->_build_head_colgroups();
        $output .= $N.$T . _tag_it('colgroup', $attribs, $cdata);
    }

    # go ahead and stop if they don't want the head
    return "$output\n" if $self->{'no_head'};

    # prepare <tr> tag info
    my $tr_attribs = _merge_attribs(
        $self->{'head'}->{'tr'}, $self->{'global'}->{'tr'}
    );
    my $tr_cdata   = $self->_build_head_row();

    # prepare the <thead> tag info
    $attribs = $self->{'head'}->{'thead'} || $self->{'global'}->{'thead'};
    $cdata   = $N.$T . _tag_it('tr', $tr_attribs, $tr_cdata) . $N.$T;

    # add the <thead> tag to the output
    $output .= $N.$T . _tag_it('thead', $attribs, $cdata) . $N;
}

sub _build_head_colgroups {
    my ($self) = @_;
    my (@cols,$output);

    return unless $self->{'colgroups'};
    return undef unless @cols = @{$self->{'colgroups'}};

    foreach (@cols) {
        $output .= $N.$T.$T . _tag_it('col', $_);
    }
    $output .= $N.$T;

    return $output;
}

sub _build_head_row {
    my ($self) = @_;
    my $output = $N;
    my @copy   = @{$self->{'fields_arry'}};

    foreach my $field (@copy) {
        my $attribs = _merge_attribs(
            $self->{$field}->{'th'}   || $self->{'head'}->{'th'},
            $self->{'global'}->{'th'} || $self->{'head'}->{'th'},
        );

        if (my $sub = $self->{'map_head'}->{$field}) {
            $field = $sub->($field);
        }
        elsif (!$self->{'no_ucfirst'}) {
            $field = ucfirst( lc( $field ) );
        }

        # bug 21761 "Special XML characters should be expressed as entities"
        $field = $self->_xml_encode( $field ) if $self->{'encode_cells'};

        $output .= $T.$T . _tag_it('th', $attribs, $field) . $N;
    }

    return $output . $T;
}

sub _build_body {

    my ($self)   = @_;
    my $beg      = 0;
    my $output;

    # if a group was not set via set_group(), then use the entire 2-d array
    my @indicies = exists $self->{'body_breaks'}
        ? @{$self->{'body_breaks'}}
        : ($self->get_row_count - 1);

    # the skinny here is to grab a slice of the rows, one for each group
    foreach my $end (@indicies) {
        my $body_group = $self->_build_body_group([@{$self->{'rows'}}[$beg..$end]]) || '';
        my $attribs    = $self->{'global'}->{'tbody'} || $self->{'body'}->{'tbody'};
        my $cdata      = $N . $body_group . $T;

        $output .= $T . _tag_it('tbody',$attribs,$cdata) . $N;
        $beg = $end + 1;
    }
    return $output;
}

sub _build_body_group {

    my ($self,$chunk) = @_;
    my ($output,$cdata);
    my $attribs = _merge_attribs(
        $self->{'body'}->{'tr'}, $self->{'global'}->{'tr'}
    );
    my $pk_col = '';

    # build the rows
    for my $i (0..$#$chunk) {
        my @row  = @{$chunk->[$i]};
        $pk_col  = splice(@row,$self->{'pk_index'},1) if defined $self->{'pk_index'};
        $cdata   = $self->_build_body_row(\@row, ($i and $self->{'nodup'} or 0), $pk_col);
        $output .= $T . _tag_it('tr',$attribs,$cdata) . $N;
    }

    # build the subtotal row if applicable
    if (my $subtotals = shift @{$self->{'sub_totals'}}) {
        $cdata   = $self->_build_body_subtotal($subtotals);
        $output .= $T . _tag_it('tr',$attribs,$cdata) . $N;
    }

    return $output;
}

sub _build_body_row {
    my ($self,$row,$nodup,$pk) = @_;

    my $group  = $self->{'group'};
    my $index  = $self->_lookup_index($group) if $group;
    my $output = $N;

    $self->{'current_row'} = $pk;

    for (0..$#$row) {
        my $name    = $self->_lookup_name($_);
        my $attribs = _merge_attribs(
            $self->{$name}->{'td'}    || $self->{'body'}->{'td'}, 
            $self->{'global'}->{'td'} || $self->{'body'}->{'td'},
        );

        # suppress warnings AND keep 0 from becoming &nbsp;
        $row->[$_] = '' unless defined($row->[$_]);

        # bug 21761 "Special XML characters should be expressed as entities"
        $row->[$_] = $self->_xml_encode( $row->[$_] ) if $self->{'encode_cells'};

        my $cdata = ($row->[$_] =~ /^\s+$/) 
            ? $self->{'null_value'}
            : $row->[$_] 
        ;

        $self->{'current_col'} = $name;

        $cdata = ($nodup and $index == $_)
            ? $self->{'nodup'}
            : _map_it($self->{'map_cell'}->{$name},$cdata)
        ;

        $output .= $T.$T . _tag_it('td', $attribs, $cdata) . $N;
    }
    return $output . $T;
}

sub _build_body_subtotal {
    my ($self,$row) = @_;
    my $output = $N;

    return '' unless $row;

    for (0..$#$row) {
        my $name    = $self->_lookup_name($_);
        my $sum     = ($row->[$_]);
        my $attribs = _merge_attribs(
            $self->{$name}->{'th'}    || $self->{'body'}->{'th'},
            $self->{'global'}->{'th'} || $self->{'body'}->{'th'},
        );

        # use sprintf if mask was supplied
        if ($self->{'subtotals_mask'} and defined $sum) {
            $sum = sprintf($self->{'subtotals_mask'},$sum);
        }
        else {
            $sum = (defined $sum) ? $sum : $self->{'null_value'};
        }

        $output .= $T.$T . _tag_it('th', $attribs, $sum) . $N;
    }
    return $output . $T;
}

sub _build_foot {
    my ($self) = @_;

    my $tr_attribs = _merge_attribs(
        # notice that foot is 1st and global 2nd - different than rest
        $self->{'foot'}->{'tr'}, $self->{'global'}->{'tr'}
    );
    my $tr_cdata   = $self->_build_foot_row();

    my $attribs = $self->{'foot'}->{'tfoot'} || $self->{'global'}->{'tfoot'};
    my $cdata   = $N.$T . _tag_it('tr', $tr_attribs, $tr_cdata) . $N.$T;

    return $T . _tag_it('tfoot',$attribs,$cdata) . $N;
}

sub _build_foot_row {
    my ($self) = @_;

    my $output = $N;
    my $row    = $self->{'totals'};

    for (0..$#$row) {
        my $name    = $self->_lookup_name($_);
        my $attribs = _merge_attribs(
            $self->{$name}->{'th'}    || $self->{'foot'}->{'th'},
            $self->{'global'}->{'th'} || $self->{'foot'}->{'th'},
        );
        my $sum     = ($row->[$_]);

        # use sprintf if mask was supplied
        if ($self->{'totals_mask'} and defined $sum) {
            $sum = sprintf($self->{'totals_mask'},$sum)
        }
        else {
            $sum = defined $sum ? $sum : $self->{'null_value'};
        }

        $output .= $T.$T . _tag_it('th', $attribs, $sum) . $N;
    }
    return $output . $T;
}

# builds a tag and it's enclosed data
sub _tag_it {
    my ($name,$attribs,$cdata) = @_;
    my $text = "<\L$name\E";

    # build the attributes if any - skip blank vals
    for my $k (sort keys %{$attribs}) {
        my $v = $attribs->{$k};
        if (ref $v eq 'HASH') {
            $v = join('; ', map { 
                my $attrib = $_;
                my $value  = (ref $v->{$_} eq 'ARRAY') 
                    ? _rotate($v->{$_}) 
                    : $v->{$_};
                join(': ',$attrib,$value||'');
            } sort keys %$v) . ';';
        }
        $v = _rotate($v) if (ref $v eq 'ARRAY');
        $text .= qq| \L$k\E="$v"| unless $v =~ /^$/;
    }
    $text .= (defined $cdata) ? ">$cdata</\L$name\E>" : '/>';
}

# used by map_cell() and map_head()
sub _map_it {
    my ($sub,$datum) = @_;
    return $datum unless $sub;
    return $datum = $sub->($datum);
}

# used by calc_totals() and calc_subtotals()
sub _total_chunk {
    my ($self,$chunk,$indexes) = @_;
    my %totals;

    foreach my $row (@$chunk) {
        foreach (@$indexes) {
            $totals{$_} += $row->[$_] if $row->[$_] =~ /^[-0-9\.]+$/;
        }    
    }

    return [ map { defined $totals{$_} ? $totals{$_} : undef } (0 .. $self->get_col_count() - 1) ];
}

# uses %ESCAPES to convert the '4 Horsemen' of XML
# big thanks to Matt Sergeant 
sub _xml_encode {
    my ($self,$str) = @_;
    $str =~ s/([&<>"])/$ESCAPES{$1}/ge;
    return $str;
}

# returns value of and moves first element to last
sub _rotate {
    my $ref  = shift;
    my $next = shift @$ref;
    push @$ref, $next;
    return $next;
}

# always returns an array ref
sub _refinate {
    my ($self,$ref) = @_;
    $ref = undef if ref($ref) eq 'ARRAY' && scalar( @$ref ) < 1;
    $ref = [@{$self->{'fields_arry'}}] unless defined $ref;
    $ref = [$ref] unless ref $ref eq 'ARRAY';
    return [map {$_ =~ /^\d+$/ ? $self->_lookup_name($_) || $_ : $_} @$ref];
}

sub _merge_attribs {
    my ($hash1,$hash2) = @_;

    return $hash1 unless $hash2;
    return $hash2 unless $hash1;

    return {%$hash2,%$hash1};
}

sub _lookup_name {
    my ($self,$index) = @_;
    return $self->{'fields_arry'}->[$index];

lib/DBIx/XHTML_Table.pm  view on Meta::CPAN

  # with attributes
  $table->modify(
     caption => 'A Table Of Contents',
     { align => 'bottom' }
  );

  # without attributes
  $table->modify(caption => 'A Table Of Contents');

The only tag that cannot be modified by modify() is the <col>
tag. Use add_col_tag() instead.

=item B<modify_tag>

  $table->modify_tag($tag,$attribs[,$cols])

Deprecated, use the easier to type modify() instead.

=item B<add_col_tag>

  $table->add_col_tag($cols)

Add a new <col> tag and attributes. The only argument is reference
to a hash that contains the attributes for this <col> tag. Multiple
<col> tags require multiple calls to this method. The <colgroup> tag
pair will be automatically generated if at least one <col> tag is
added.

Advice: use <col> and <colgroup> tags wisely, don't do this:

  # bad
  for (0..39) {
    $table->add_col_tag({
       foo => 'bar',
    });
  }

When this will suffice:

  # good
  $table->modify(colgroup => {
     span => 40,
     foo  => 'bar',
  });

You should also consider using <col> tags to set the attributes
of <td> and <th> instead of the <td> and <th> tags themselves,
especially if it is for the entire table. Notice the use of the
get_col_count() method in this example to span the entire table:

  $table->add_col_tag({
     span  => $table->get_col_count(),
     style => 'text-align: center',
  });

=item B<map_cell>

  $table->map_cell($subroutine[,$cols])

Map a supplied subroutine to all the <td> tag's cdata for
the specified columns.  The first argument is a reference to a
subroutine. This subroutine should shift off a single scalar at
the beginning, munge it in some fasion, and then return it.
The second argument is the column (scalar) or columns (reference
to a list of scalars) to apply this subroutine to. Example: 

  # uppercase the data in column DEPARTMENT
  $table->map_cell( sub { return uc shift }, 'department');

  # uppercase the data in the fifth column
  $table->map_cell( sub { return uc shift }, 4);

One temptation that needs to be addressed is using this method to
color the cdata inside a <td> tag pair. For example:

  # don't be tempted to do this
  $table->map_cell(sub {
    return qq|<font color="red">| . shift . qq|</font>|;
  }, [qw(first_name last_name)]);

  # when CSS styles will work
  $table->modify(td => {
    style => 'color: red',
  }, [qw(first_name last_name)]);

Note that the get_current_row() and get_current_col()
can be used inside the sub reference. See set_pk() below
for an example.

All columns are used if none are specified, and you can
specify index number(s) as well as name(s).  Also,
exec_query() must be called and data must be returned
from the database prior to calling this method, otherwise
the call back will be ignored and a warning will be generated.
This is true for map_head() as well.

=item B<map_col>

  $table->map_col($subroutine[,$cols])

Deprecated - use map_cell() instead.

=item B<map_head>

  $table->map_head($subroutine[,$cols])

Just like map_cell() except it modifies only column headers, 
i.e. the <th> data located inside the <thead> section. The
immediate application is to change capitalization of the column
headers, which are defaulted to ucfirst:

  $table->map_head(sub { uc shift });

Instead of using map_head() to lower case the column headers,
just specify that you don't want default capitalization with
output():

  $table->output({ no_ucfirst => 1 });

=item B<set_row_colors>

  $table->set_row_colors($colors[,$attrib_name]);

This method will produce horizontal stripes.
This first argument is an array reference that contains
the colors to use. Each row will get a color from the
list - when the last color in the list is reached,
then the rotation will start over at the beginning.
This will continue until all <tr> tags have been
generated. If you don't supply an array reference with
at least 2 colors then this method will return without
telling you.

set_row_colors() by default will use CSS styles to