File Coverage

blib/lib/SignalWire/CompatXML.pm

Criterion	Covered	Total	%
statement	147	147	100.0
branch	35	40	87.5
condition	11	15	73.3
subroutine	24	25	96.0
pod	8	13	61.5
total	225	240	93.7

package SignalWire::CompatXML;

use 5.008001;
use strict;
use warnings;
use Carp 'croak';
use Scalar::Util 'blessed';

our $VERSION = '1.0';
our $AUTOLOAD;
our $NL = "\n";
our $STRICT = 0;
our %TAGS   = ();

sub new {
    my $class = shift;
    my $self  = {};
    bless $self, $class;

    $self->{_name}       = '';
    $self->{_attributes} = {};
    $self->{_parent}     = undef;
    $self->{_content}    = '';

    {
        no strict 'refs';
        my %args = @_;
        for my $arg ( keys %args ) {
            if( exists $self->{"_$arg"} ) {
                $self->$arg($args{$arg});
            }
        }
    }

    return $self;
}

sub name {
    my $self = shift;

    if( @_ ) {
        $self->{_name} = shift;
    }

    $self->{_name};
}

sub parent {
    my $self = shift;

    if( @_ ) {
        $self->{_parent} = shift;
    }

    $self->{_parent};
}

sub content {
    my $self = shift;
    my @args = grep { defined $_ } @_;

    if( @args ) {
        my $arg = shift;

        ## an object
        if( ref($arg) ) {
            $arg->parent($self);
            $self->{_content} = [ $arg ];
            return $arg;
        }

        ## http://www.w3.org/TR/REC-xml/#syntax
        $arg =~ s{\&}{&}g;
        $arg =~ s{\<}{<}g;
        $arg =~ s{\>}{>}g;
        $arg =~ s{\"}{"}g;
        $arg =~ s{\'}{'}g;

        $self->{_content} = $arg;
    }

    $self->{_content};
}

sub attributes {
    my $self = shift;

    if( @_ ) {
        $self->{_attributes} = shift;
    }

    $self->{_attributes};
}

sub add_child {
    my $self = shift;
    my $child = shift;

    $child->parent($self);
    $self->{_content} ||= [];
    push @{$self->{_content}}, $child;

    return $child;
}

sub root {
    my $self = shift;

    if( $self->{_parent} ) {
        return $self->{_parent}->root;
    }

    return $self;
}

sub to_string {
    my $self = shift;
    my $hdrs = shift || {};

    my @headers = ();
    for my $hdr ( sort keys %$hdrs ) {
        push @headers, $hdr . ': ' . $hdrs->{$hdr};
    }
    push @headers, '' if scalar(@headers);

    join($NL, @headers, $self->to_list);
}

sub to_list {
    my $self = shift;
    my $sp   = shift || 0;

    my @str = ();

    ## named element
    if( $self->name ) {
        if( my $content = $self->content ) {
            push @str, (' ' x $sp) . $self->otag;

            my $is_str = 0;

            if( ref($content) eq 'ARRAY' ) {
                for my $child ( @$content ) {
                    push @str, $child->to_list($sp + ($child->parent->name ? 2 : 0));
                }
            }

            else {
                $is_str = 1;
                $str[$#str] .= $content || '';
            }

            if( $is_str ) {
                $str[$#str] .= $self->ctag;
            }
            else {
                push @str, (' ' x $sp) . $self->ctag;
            }
        }

        ## no content; make a tidy tag
        else {
            push @str, (' ' x $sp) . $self->octag;
        }
    }

    ## unnamed (root) element
    else {
        push @str, qq!!;

        my $content = $self->content;

        my $is_str = 0;
        if( ref($content) eq 'ARRAY' ) {
            for my $child ( @$content ) {
                push @str, $child->to_list($sp + ($child->parent->name ? 2 : 0));
            }
        }

        else {
            $is_str = 1;
            $str[$#str] .= $content || '';
        }

        push @str, '';
    }

    return @str;
}

sub otag {
    return '<' . $_[0]->name . $_[0]->_attr_str . '>';
}

sub ctag {
    return 'name . '>';
}

sub octag {
    return '<' . $_[0]->name . $_[0]->_attr_str . ' />';
}

sub _attr_str {
    my $self = shift;
    my $str  = '';

    my %attr = %{ $self->attributes };

    for my $key ( sort keys %attr ) {
        my $val = $attr{$key} || '';
        $str .= ' ';
        $str .= qq!$key="$val"!;
    }

    return $str;
}

sub can {
    my $self = shift;
    my $method = shift;

    ## NOTE: this probably breaks inheritance
    if( $STRICT and keys %TAGS ) {
        unless( exists $TAGS{$method} ) {
            no strict 'refs';
            undef *{ $method };
            return;
        }
    }

    my $meth_ref = $self->SUPER::can($method);
    return $meth_ref if $meth_ref;

    $meth_ref = sub {
        my $me = shift;

        my $child = new blessed $me;
        $child->name($method);

        for my $arg ( @_ ) {
            if( ref($arg) ) {
                $child->attributes($arg);
            }
            else {
                $child->content($arg);
            }
        }

        $me->add_child($child);

        return $child;
    };

    no strict 'refs';
    return *{ $method } = $meth_ref;
}

sub AUTOLOAD {
    my $self = $_[0];

    my $method = $AUTOLOAD;
    $method =~ s/^(.*):://;

    my $meth_ref = $self->can($method);
    croak "Undefined subroutine $method\n"
	unless $meth_ref;

    goto &$meth_ref;
}

sub DESTROY { }

1;
__END__