File Coverage

blib/lib/XML/WriterX/Simple.pm

Criterion	Covered	Total	%
statement	55	62	88.7
branch	40	54	74.0
condition	11	11	100.0
subroutine	7	7	100.0
pod	3	4	75.0
total	116	138	84.0

package XML::WriterX::Simple;
$XML::WriterX::Simple::VERSION = '0.151400';
#ABSTRACT:Make XML production simpler.
use 5.006;
use strict;
use warnings FATAL => 'all';



sub XML::Writer::produce{
    my $writer  = shift;

    TAG:
    while( my $tagName = shift ){
        my ($attr, $children, $text) = XML::WriterX::Simple::arrange_args( $writer, shift );
        if(($text//'') eq '' and !@$children){
            $writer->emptyTag( $tagName, @$attr );
        }
        else{
            if(ref($text) eq 'CODE'){
                XML::WriterX::Simple::produce_content( $writer, $tagName => $text );
            }
            else{
                $writer->startTag( $tagName, @$attr );
                $writer->characters( $text ) if defined $text;
                while( @$children ){
                    my ($tag, $content) = (shift(@$children), shift(@$children));
                    $tag = ".$tagName" if $tag =~ /^[&"]$/ and ref $content eq 'CODE';
                    XML::WriterX::Simple::produce_content( $writer, $tag => $content );
                }
                $writer->endTag( $tagName );
            }
        }
    }
    #return writer to allow chaining
    $writer;
}


sub stringify{
    local $_ = shift;
    return $_ unless ref;
    if(ref eq 'ARRAY'){
    }
    elsif(ref eq 'HASH'){
    }
    elsif(ref eq 'SCALAR'){
        return $$_;
    }
    elsif(ref eq 'REF'){
        return stringify( $$_ );
    }
    return "$_";#? REGEXP or GLOB or blessed object... : let's use perl stringifier
}

sub arrange_args{
    my ($writer, $tagContent) = @_;
    my (@attr, @children, $text);
    if(ref $tagContent eq 'CODE'){
        $text = $tagContent;
    }
    elsif(defined $tagContent){
        @_ = @$tagContent if ref $tagContent eq 'ARRAY';
        @_ = %$tagContent if ref $tagContent eq 'HASH';
        @_ = ('"', $$tagContent) if ref($tagContent) =~ /^(SCALAR|REF)$/;
        @_ = ('"', $tagContent) if !ref $tagContent;
        while( @_ ){
            my ($tag,$content) = (shift, shift);
            if($tag =~ /^#/){
                #comment is added as a children
                push @children, $tag => $content;
            }
            elsif($tag =~ /^:attr/ and ref($content) =~ /^(ARRAY|HASH)$/){
                #multiple attributes in $content
                my @attrs = $1 eq 'ARRAY' ? @$content : %$content;
                #!warning if %attr != @$content : attribute name must be unique!
                push @attr, shift(@attrs), shift(@attrs) while @attrs;
            }
            elsif($tag =~ /^:(.*)/){
                #single attribute named $1 value is stringify($content)
                push @attr, $1 => $content;
            }
            else{
                #(processing instruction are added as a children like all other cases)
                push @children, $tag => $content;
            }
        }
    }
    return (\@attr, \@children, $text);
}


#CANNOT:
#   - produce a comment from a sub{}
#   - produce a tag attributes from a sub{}
#   - prodice attributes from a sub{} ?
sub produce_content{
    my ($writer, $tag, $content) = @_;

    unless($tag){
        warn "try to produce content without any tag name!";
        $DB::single=1;
        return;
    }

    if(ref($content) eq 'CODE'){
        $writer->startTag( $tag ) unless $tag =~ /^\./;
        $content->( $writer, $tag );
        $writer->endTag( $tag ) unless $tag =~ /^\./;
        return;
    }

    return $writer->characters( stringify( $content ) )
        if $tag eq '"';

    return $writer->comment( stringify $content )
        if $tag =~ /^#/;

    return $writer->pi( $1 => stringify $content )
        if $tag =~ /^\?(.*)/;

    return $writer->produce( $tag, $$content )
        if ref $content eq 'SCALAR';

    return $writer->produce( $tag, $content );
}


1; # End of XML::WriterX::Simple

__END__