File Coverage

blib/lib/Text/XML.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Text::XML;
use strict;
use warnings;
use Types;
use Text::Pretty qw(:all !text);
use Exporter;
use base qw/Exporter/;

our $VERSION = '0.1';

sub pptext ($) { Text::Pretty::text(shift) }

our @EXPORT_OK = qw(elem ielem attr text comment cdata);

our %EXPORT_TAGS = ( all => \@EXPORT_OK );

newtype Text::XML::Attribute;
newtype Text::XML::Element;
newtype Text::XML::Text;
newtype Text::XML::Comment, sub{ shift !~ qr{-->}   };
newtype Text::XML::CData,   sub{ shift !~ qr{]]>}   };
newtype Text::XML::Name,    sub{ shift =~ qr{^[\w:-]*$} };

uniontype Text::XML::XML, qw(Text::XML::Element
                             Text::XML::Attribute
                             Text::XML::Text
                             Text::XML::Comment
                             Text::XML::CData
                             Text::XML::Name);

# element( name, [element|Text|CData|Comment] )
sub elem (*;$$) { Element( Name(shift), shift() || [], shift() || [] ) }
# inline-element( name, [element|Text|CData|Comment] )
sub ielem (*;$$){ Element( Name(shift), shift() || [], shift() || [], 1 ) }
sub attr   ($$) { Attribute( Name(shift), shift ) }
sub text    ($) { Text(shift)            }
sub comment ($) { Comment(shift)         }
sub cdata   ($) { CData(shift)           }

instance Text::Pretty::Print, Text::XML::XML,
pretty => sub
{ my( $doc, %opts ) = @_
; $opts{encoding} = 'UTF-8' unless defined $opts{encoding}
; $opts{indent}   = 4       unless defined $opts{indent}
; $doc = pretty_proc($doc, $opts{indent})
; $opts{doctype}
? $doc = vcat [ hcat [ pptext '
                     , (nest 10, hsep [ (map {pptext $_} @{$opts{doctype}}) ])
                     , pptext '>'
                     ]
              , $doc
              ]
: undef
; $opts{prolog}
? $doc = vcat [ hcat [ pptext '
                     , (nest 6, hsep [ pretty_proc( attr( version => '1.0' )
                                                  , $opts{indent}         )
                                     , pretty_proc( attr( 'encoding'
                                                        , $opts{encoding} )
                                                  , $opts{indent}          )
                                     ])
                     , pptext '?>'
                     ]
              , $doc
              ]
: undef
; $doc->pretty(%opts)
};

sub pretty_proc ($$)
{ no strict
; my($doc,$i)=@_
; asserttype Text::XML::XML, $doc
; match $doc
=> Text::XML::Name
           => sub{ pptext shift }
=> Text::XML::Element
           => sub{ my( $n, $as, $cs, $inline ) = @_
             ; $inline
             ? hcat [ langle
                    , pretty_proc($n,$i)
                    , ( @$as ? ( space
                               , hsep [map {onel pretty_proc($_,$i)} @$as]
                               )
                            : () )
                    , ( @$cs ? rangle
                             : pptext ' />' )
                    , ( @$cs ? ( nest($i, hcat [(map {pretty_proc($_,$i)} @$cs)
                                               , pptext '
                                               , pretty_proc($n,$i)
                                               , rangle
                                               ])
                                )
                            : () )
                    ]
            : vcat [ hcat [ langle
                          , pretty_proc($n,$i)
                          , ( @$as ? ( space
                                     , (nest 2+length $n->[0]
                                           , hsep [map {pretty_proc($_,$i)}
                                                       @$as                 ])
                                     )
                                  : () )
                          , ( @$cs ? rangle
                                   : pptext ' />' )
                          ]
                    , ( @$cs ? ( nest($i, vcat [map {pretty_proc($_,$i)} @$cs])
                                , hcat [ pptext '
                                       , pretty_proc($n,$i)
                                       , rangle
                                       ]
                                )
                            : () )
                    ]
                   }
=> Text::XML::Attribute => sub{ my($n,$v) = @_
                   ; defined $v
                        ? do{ $v =~ s{&}{&}gsm
                            ; $v =~ s{"}{"}gsm
                            ; onel hcat [ pretty_proc($n,$i)
                                        , equals
                                        , qquotes pptext $v
                                        ]
                            }
                        : pretty_proc($n,$i)
                   }
=> Text::XML::Text
             => sub{ my $t = shift
                   ; $t =~ s{&}{&}gsm
                   ; $t =~ s{<}{<}gsm
                   ; $t =~ s{>}{>}gsm
                   ; words $t
                   }
=> Text::XML::Comment
             => sub{ hsep [ pptext ''
                          ]
                   }
=> Text::XML::CData
             => sub{ onel hcat [ pptext '
                               , pptext shift
                               , pptext ']]>'
                               ]
                   }
}

1;

__END__