File Coverage

blib/lib/XML/Spew.pm

Criterion	Covered	Total	%
statement	12	72	16.6
branch	0	14	0.0
condition	0	3	0.0
subroutine	4	13	30.7
pod			n/a
total	16	102	15.6

package XML::Spew;

use warnings;
use strict;

our $VERSION = '0.02';

use Carp;

sub _new {
    my $class = shift;

    return bless { stack => [ ] }, ref( $class ) || $class;
}

sub _tags {
    my $class = shift;

    croak "_tags must be passed at least one argument" unless @_;
    my @tags = @_;

    foreach my $tag( @tags ) {
        # install methods
        {
            no strict 'refs';
            *{ $class . '::'       . $tag } = $class->__m_meth( $tag );
            *{ $class . '::start_' . $tag } = $class->__s_meth( $tag );
            *{ $class . '::end_'   . $tag } = $class->__e_meth( $tag );
        }
    }
}

# returns a coderef for the main tag method
sub __m_meth {
    my $class = shift;
    my $tag = shift;

    return sub {
        my $self = shift;
        my $r = '<' . $tag;

        # check for attributes
        if( ref( $_[0] ) eq 'HASH' ) {
            $r .= $self->__attributes( shift );
        }

        # check if we have an arrayref to distribute over
        if( ref( $_[0] ) eq 'ARRAY' ) {
            $r .= '>';
            my $e = '';
            return map { $r . $_ . $e } @{ $_[0] };
        }

        # check if we have child data
        if( @_ ) {
            $r .= '>' . join '', @_;
            $r .= '';
        } else {
            $r .= ' />';
        }

        return $r;
    };
}

# returns a coderef for the start tag method
sub __s_meth {
    my $class = shift;
    my $tag = shift;

    return sub {
        my $self = shift;
        my $r = '<' . $tag;

        # push this tag onto the tag stack
        push @{ $self->{stack} }, $tag;

        # check for attributes
        if( ref( $_[0] ) eq 'HASH' ) {
            $r .= $self->__attributes( shift );
        }

        # check for erroneous data
        if( @_ ) {
            carp "Ignoring extra arguments to start_$tag(). You might want $tag().";
        }

        $r .= '>';

        return $r;
    };
}

# returns a coderef for the end tag method
sub __e_meth {
    my $class = shift;
    my $tag = shift;

    return sub {
        my $self = shift;

        # fatal error if this tag is not on top of the stack
        my $top = $self->{stack}[-1];
        unless( $top eq $tag ) {
            croak "Invalid nesting: can not close <$tag> while <$top> still open";
        }

        # pop this tag off the stack and close it
        pop @{ $self->{stack} };

        return '';
    };
}


sub __attributes {
    my $self = shift;
    my $attr_ref = shift;

    my $r;
    while( my( $k, $v ) = each %$attr_ref ) {
        $r .= " $k=\"$v\"";
    }

    return $r;
}

1;

__END__