File Coverage

blib/lib/Class/DBI/ToSax.pm

Criterion	Covered	Total	%
statement	85	85	100.0
branch	27	32	84.3
condition	18	27	66.6
subroutine	11	11	100.0
pod	1	3	33.3
total	142	158	89.8

package Class::DBI::ToSax;
# @(#) $Id: ToSax.pm,v 1.25 2003/10/14 15:11:01 dom Exp $

# There's a bug in UNIVERSAL::isa() in 5.6.0 :(
use 5.006001;
use strict;
use warnings;

our $VERSION = '0.10';

use base qw( Class::Data::Inheritable );

use Carp qw( croak );
use NEXT;

sub _emit_sax_value {
    my $self = shift;
    my ( $handler, $col, $val, %opt ) = @_;
    if ( ref( $val ) && $val->can( 'to_sax' ) ) {
        # Record ourselves for our children.
        $opt{ _ancestors } ||= [];
        push @{ $opt{ _ancestors } }, $self;
        $val->to_sax( $handler, %opt );
    } else {
        my $data = {
            LocalName    => $col,
            Name         => $col,
            NamespaceURI => '',
            Prefix       => '',
        };
        $handler->start_element( $data );
        $val = '' if !defined $val || length $val == 0;
        $handler->characters(  { Data => $val } );
        $handler->end_element( $data );
    }
}

our %seen;
sub to_sax {
    my $self  = shift;
    my $class = ref $self;
    my ( $handler, %opt ) = @_;
    croak "usage: to_sax(handler,opt)\n"
      unless $handler && ref $handler && $handler->can( 'start_element' );

    # NB: Hack alert!  Calling this in array context /should/ work
    # correctly in all versions of Class::DBI, whether before or after
    # MCPK support was added.
    my @pk = $self->primary_column;
    # Avoid a warning with an undef id.  In reality, this should never
    # happen, but I've got non-database-backed objects that get
    # created without and id.  So I have to be careful here.
    my $id       = join '/', map { defined $_ ? $_ : '' } $self->get( @pk );
    my $table    = $class->table;
    my $toplevel = $opt{ notoplevel } ? 0 : !scalar %seen;
    my $wrapper  = delete $opt{ wrapper } || $self->table;

    # Ensure that we never have the same class twice in the call stack.
    return if $seen{ "$table-$id" };
    local %seen = %seen;
    $seen{ "$table-$id" }++;

    $handler->start_document( {} ) if $toplevel;
    my $table_data = {
        Name         => $wrapper,
        LocalName    => $wrapper,
        NamespaceURI => '',
        Prefix       => '',
        Attributes   => {
            '{}id' => {
                LocalName    => 'id',
                Name         => 'id',
                NamespaceURI => '',
                Prefix       => '',
                Value        => $id,
            },
        },
    };
    $handler->start_element( $table_data );

    if ( $toplevel || $self->_stop_recursion( %opt ) ) {
        my %has_a = map { $_ => 1 } @{ $self->_has_a_methods || [] };
        my %pk    = map { $_ => 1 } @pk;
        my @plain = grep { !$pk{ $_ } && !$has_a{ $_ } } $self->columns;

        foreach my $col ( sort @plain ) {
            $self->_emit_sax_value( $handler, $col, $self->$col, %opt );
        }

        foreach my $col ( sort keys %has_a ) {
            $self->_emit_sax_value( $handler, $col, $self->$col, %opt,
                wrapper => $col );
        }

        foreach my $col ( sort @{ $self->_has_many_methods || [] } ) {
            $self->_emit_sax_value( $handler, $col, $_, %opt )
                foreach $self->$col;
        }
    }

    $handler->end_element( $table_data );
    $handler->end_document( {} ) if $toplevel;
}

# If this function returns true, we won't recurse into this object,
# leaving just a reference to the object.  There are a number of ways in
# which to take this decision...
sub _stop_recursion {
    my $self = shift;
    my ( %opt ) = @_;
    return 1 unless exists $opt{ norecurse };

    my $norecurse = $opt{ norecurse };
    if ( !ref $norecurse ) {
        # A simple true scalar will stop all recursion.
        return !$norecurse;
    } elsif ( ref $norecurse eq 'HASH' ) {
        # If the hash entry for this table is true, stop the recursion.
        return !$norecurse->{ $self->table };
    } elsif ( ref $norecurse eq 'CODE' ) {
        # If we've been given a lambda, punt the decision to it.  Note
        # that the return code is the reverse of what actually happens,
        # in order to make it similiar to the hash ref case.
        my @ancestors = @{ $opt{ _ancestors } || [] };
        return !$norecurse->( @ancestors, $self );
    }
}

# Override has_many() so that we can capture the method name.
__PACKAGE__->mk_classdata( '_has_many_methods' );
sub has_many {
    my $class = shift;
    my ( $method ) = @_;
    my $method_list = $class->_has_many_methods || [];
    push @$method_list, $method;
    $class->_has_many_methods( $method_list );
    return $class->NEXT::has_many( @_ );
}

# Ditto for has_a relationships.
__PACKAGE__->mk_classdata( '_has_a_methods' );
sub has_a {
    my $class = shift;
    my ( $method ) = @_;
    my $method_list = $class->_has_a_methods || [];
    push @$method_list, $method;
    $class->_has_a_methods( $method_list );
    return $class->NEXT::has_a( @_ );
}

1;
__END__