File Coverage

blib/lib/XML/Generator/DBI.pm

Criterion	Covered	Total	%
statement	12	191	6.2
branch	0	108	0.0
condition	0	26	0.0
subroutine	4	18	22.2
pod	3	14	21.4
total	19	357	5.3

# $Id: DBI.pm,v 1.8 2003/08/18 21:15:27 matt Exp $

package XML::Generator::DBI;
use strict;

use MIME::Base64;
use XML::SAX::Base;

use vars qw($VERSION @ISA);

$VERSION = '1.00';
@ISA = ('XML::SAX::Base');

my %defaults = (
        RootElement => "database",
        QueryElement => "select",
        RowElement => "row",
        ColumnsElement => "columns",
        ColumnElement => "column",
    );

sub new {
    my $class = shift;
    my $s = $class->SUPER::new(@_);
    my $self = bless { %defaults, %$s }, ref($s);

    return $self;
}

sub execute {
    my $self = shift;
    my ($query, $bind, %p) = @_;

    my %params = (%defaults, %$self, %p);

    # This might confuse people, but the methods are actually
    # called on this proxy object, which is a mirror of $self
    # with the new params inserted.
    my $proxy = bless \%params, ref($self);

    # turn on throwing exceptions
    local $proxy->{dbh}->{RaiseError} = 1;

    $proxy->pre_execute();
    $proxy->execute_one($query, $bind);
    $proxy->post_execute();

}

sub pre_execute {
    my $proxy = shift;

    # TODO - figure out how to call set_document_locator() here

    $proxy->SUPER::start_document({});
    $proxy->SUPER::start_prefix_mapping({ Prefix => 'dbi', NamespaceURI => 'http://axkit.org/NS/xml-generator-dbi' });
    $proxy->send_start($proxy->{RootElement});
}

sub post_execute {
    my $proxy = shift;

    $proxy->send_end($proxy->{RootElement});
    $proxy->SUPER::end_prefix_mapping({ Prefix => 'dbi', NamespaceURI => 'http://axkit.org/NS/xml-generator-dbi' });
    $proxy->SUPER::end_document({});
}

sub execute_one {
    my ($self, $query, $bind, %p) = @_;

    my %params = (%defaults, %$self, %p);

    # create yet another proxy object
    my $proxy = bless \%params, ref($self);

    my @bind;
    if (defined($bind)) {
        @bind = ref($bind) ? @{$bind} : ($bind);
    }

    my $sth;
    if (ref($query)) {
        # assume its a statement handle
        $sth = $query;
        $query = "Unknown - executing statement handle";
    }
    else {
        $sth = $proxy->{dbh}->prepare($query);
    }

    $sth->execute(@bind);

    #open QueryElement if defined
    if($proxy->{QueryElement}){
        $proxy->send_start($proxy->{QueryElement}, $proxy->{ShowSQL} ? (query => $query) : ());
    }

    my $names = $proxy->{LowerCase} ? $sth->{NAME_lc} : $sth->{NAME};

    #get index of group field
    my $group_by_ind;
    if(defined $proxy->{GroupBy}){
        $group_by_ind = 0;
        foreach my $name (@$names){
            last if $name eq $proxy->{GroupBy};
            $group_by_ind++;
        }
    }

    # output columns if necessary
    $proxy->add_column_info($sth, $names);

    my @row;
    $sth->bind_columns(
            \( @row[ 0 .. $#{$names} ] )
        );

    my $group;

    while ($sth->fetch) {
        my @encoding;
        my $i = 0;
        foreach (@row) {
            if (defined($_) and /[\x00-\x08\x0A-\x0C\x0E-\x19]/) {
                # in foreach loops, $_ is an lvalue!
                $_ = MIME::Base64::encode_base64($_);
                $encoding[$i] = 'base64';
            }
            $i++;
        }

        if ($proxy->{AsAttributes}) {
            $proxy->send_attributes_row(\@row, $names, \@encoding, \$group, $group_by_ind);
        }
        else {
            $proxy->send_tags_row(\@row, $names, \@encoding, \$group, $group_by_ind);
        }
    }

    # close previous group element if any
    $proxy->send_end($proxy->{GroupElement}) if defined $proxy->{GroupElement};

    # close QueryElement if defined
    $proxy->send_end($proxy->{QueryElement}) if $proxy->{QueryElement};
}

sub send_tags_row {
    my $proxy = shift;
    my ($row, $names, $encoding, $group, $group_by_ind) = @_;

    $proxy->send_group($row, $group, $group_by_ind);

    $proxy->send_start($proxy->{RowElement}) if $proxy->{RowElement};

    my @stack;
    my @el_stack;

    # for each column...
    foreach my $i (0 .. $#{$names}) {
        # skip group element
        if (defined($proxy->{GroupBy}) and $i == $group_by_ind){
            next;
        }

        # get the element stack: address/street ->
        if ($proxy->{ByColumnName}) {
            @el_stack = split(/\//, $names->[$i]);
            if(! defined $el_stack[0]){
                shift @el_stack;
            }
        }
        else {
            @el_stack = ($names->[$i]);
        }

        my $stack_len = $#stack;
        my $el_stack_len = $#el_stack;

        my $ind = 0;
        while ($el_stack[$ind] eq $stack[$ind] and
               $ind <= $stack_len and
               $ind <= $el_stack_len)
        {
            $ind ++;
        }

        if ($el_stack[$ind] eq $stack[$ind] and $el_stack_len == $stack_len) {
            # We're already at the end of the stack, so output the column
            $proxy->send_tag($names->[$i], $row->[$i],
                            $encoding->[$i] ?
                                ('dbi:encoding' => $encoding->[$i])
                                :
                                ()
            ) if defined($row->[$i]);
        }
        else {
            # Otherwise we need to close all previous tags...
            foreach my $n ($ind .. $stack_len){
                $proxy->send_end(pop @stack);
            }

            # And open all the new ones...
            foreach my $n ($ind .. ($el_stack_len - 1) ){
                push @stack, $el_stack[$n];
                $proxy->send_start($el_stack[$n]);
            }

            # Then send the column
            $proxy->send_tag($el_stack[$el_stack_len], $row->[$i],
                            $encoding->[$i] ?
                                ('dbi:encoding' => $encoding->[$i])
                                :
                                ()
            ) if defined($row->[$i]);
        }
    }

    $proxy->send_end(pop @stack) while(@stack);

    $proxy->send_end($proxy->{RowElement}) if $proxy->{RowElement};
}

sub send_group {
    my $proxy = shift;
    my ($row, $group, $group_by_ind) = @_;

    # maintain GroupBy before RowElement
    if (defined $proxy->{GroupBy}) {
        if ($$group ne $row->[$group_by_ind]) { # a new group
            my $group_element = $proxy->{GroupElement} || die "GroupElement not defined";

            # close previous group element if any
            $proxy->send_end($group_element) if (defined $$group);

            if ($proxy->{GroupAttribute}) {
                #send start and value as attribute
                $proxy->send_start($group_element, $proxy->{GroupAttribute} => $row->[$group_by_ind]);
            }
            elsif ($proxy->{GroupValueElement}) {
                #send start and value as element
                $proxy->send_start($group_element);
                $proxy->send_tag($proxy->{GroupValueElement},  $row->[$group_by_ind]);
            }
            else {
                die "You have to define either 'GroupAttribute' or 'GroupValueElement'";
            }
            $$group = $row->[$group_by_ind];
        }
    }
}

sub send_attributes_row {
    my $proxy = shift;
    my ($row, $names, $encoding, $group, $group_by_ind) = @_;

    my %attribs = map { $names->[$_] => $row->[$_] } # create hash
                  grep { defined $row->[$_] } # remove undef ones
                  grep { $names->[$_] ne $proxy->{GroupBy} } #remove group data
                  (0 .. $#{$names});

    # GroupElement
    $proxy->send_group($row, $group, $group_by_ind);

    my $enc_cols = join(',',
        map { $names->[$_] }
        grep { $encoding->[$_] }
        (0 .. $#{$names}));

    my $null_cols = join(',',
        map { $names->[$_] }
        grep { !defined $row->[$_] }
        (0 .. $#{$names}));

    $proxy->send_tag($proxy->{RowElement}, undef, %attribs,
        $null_cols ? ('dbi:null-columns' => $null_cols) : (),
        $enc_cols ? ('dbi:encoded-columns' => $enc_cols) : (),
    );
}

sub add_column_info {
    my $self = shift;
    my ($sth, $names) = @_;

    return unless $self->{ShowColumns};
    return unless $self->{dbh};

    my $types = $sth->{TYPE};
    my $precision = $sth->{PRECISION};
    my $scale = $sth->{SCALE};
    my $null = $sth->{NULLABLE};
    $self->send_start($self->{ColumnsElement});
    foreach my $i (0 .. $#{$names}) {
        my $type_info = $self->{dbh}->type_info($types->[$i]);
        if ($self->{AsAttributes}) {
            my %attribs;
            $attribs{name} = $names->[$i];
            $attribs{raw_type} = $types->[$i];
            $attribs{type} = $type_info->{TYPE_NAME} if $type_info->{TYPE_NAME};
            $attribs{size} = $type_info->{COLUMN_SIZE} if $type_info->{COLUMN_SIZE};
            $attribs{precision} = $precision->[$i] if defined($precision->[$i]);
            $attribs{scale} = $scale->[$i] if defined($scale->[$i]);
            $attribs{nullable} = (!$null->[$i] ? "NOT NULL" : ($null->[$i] == 1) ? "NULL" : "UNKNOWN") if defined($null->[$i]);

            $self->send_tag($self->{ColumnElement}, undef, %attribs);
        }
        else {
            $self->send_start($self->{ColumnElement});

            $self->send_tag(name => $names->[$i]);
            $self->send_tag(raw_type => $types->[$i]);
            $self->send_tag(type => $type_info->{TYPE_NAME}) if $type_info->{TYPE_NAME};
            $self->send_tag(size => $type_info->{COLUMN_SIZE}) if $type_info->{COLUMN_SIZE};
            $self->send_tag(precision => $precision->[$i]) if defined($precision->[$i]);
            $self->send_tag(scale => $scale->[$i]) if defined($scale->[$i]);
            $self->send_tag(nullable => (!$null->[$i] ? "NOT NULL" : ($null->[$i] == 1 ? "NULL" : "UNKNOWN"))) if defined($null->[$i]);

            $self->send_end($self->{ColumnElement});
        }
    }
    $self->send_end($self->{ColumnsElement});
}

# SAX utility functions

sub sax1tosax2_attrs {
    my $attrs = shift;
    my %new_attrs;
    foreach my $k (keys %$attrs) {
        if ($k =~ /^dbi:(.*)$/) {
            my $lname = $1;
            $new_attrs{"{http://axkit.org/NS/xml-generator-dbi}$lname"} = {
                Name => $k,
                LocalName => $lname,
                Prefix => 'dbi',
                NamespaceURI => 'http://axkit.org/NS/xml-generator-dbi',
                Value => $attrs->{$k},
            };
        }
        else {
            $new_attrs{"{}$k"} = {
                Name => $k,
                LocalName => $k,
                Prefix => '',
                NamespaceURI => '',
                Value => $attrs->{$k},
            };
        }
    }
    return \%new_attrs;
}

sub send_tag {
    my $self = shift;
    my ($name, $contents, %attributes) = @_;
    $self->SUPER::characters({ Data => (" " x $self->{cur_indent}) }) if $self->{Indent} && $self->{cur_indent};
    $self->SUPER::start_element({ Name => $name, Attributes => sax1tosax2_attrs(\%attributes) });
    $self->SUPER::characters({ Data => $contents });
    $self->SUPER::end_element({ Name => $name });
    $self->new_line if $self->{Indent};
}

sub send_start {
    my $self = shift;
    my ($name, %attributes) = @_;
    $self->SUPER::characters({ Data => (" " x $self->{cur_indent}) }) if $self->{Indent} && $self->{cur_indent};
    $self->SUPER::start_element({ Name => $name, Attributes => sax1tosax2_attrs(\%attributes) });
    $self->{cur_indent}++;
    $self->new_line if $self->{Indent};
}

sub send_end {
    my $self = shift;
    my ($name) = @_;
    $self->{cur_indent}--;
    $self->SUPER::characters({ Data => (" " x $self->{cur_indent}) }) if $self->{Indent} && $self->{cur_indent};
    $self->SUPER::end_element({ Name => $name });
    $self->new_line if $self->{Indent};
}

sub new_line {
    my $self = shift;
    $self->SUPER::characters({ Data => "\n" }) if $self->{cur_indent};
}

1;
__END__