File Coverage

blib/lib/XML/Generator/PerlData.pm

Criterion	Covered	Total	%
statement	327	498	65.6
branch	117	220	53.1
condition	36	56	64.2
subroutine	29	39	74.3
pod	26	30	86.6
total	535	843	63.4

package XML::Generator::PerlData;

use strict;
use XML::SAX::Base;
use vars qw($VERSION @ISA $NS_XMLNS $NS_XML);
use Data::Dumper;
# some globals
$VERSION = '0.91';
@ISA = qw( XML::SAX::Base );
$NS_XML   = 'http://www.w3.org/XML/1998/namespace';
$NS_XMLNS = 'http://www.w3.org/2000/xmlns/';

sub new {
    my $proto = shift;
    my $self = $proto->SUPER::new( @_ );

    my %args = @_;

    delete $args{Handler} if defined $args{Handler};

    $self->{Namespaces} = { $NS_XMLNS => 'xmlns',
                            $NS_XML   => 'xml'
                          };
    $self->{DeclaredNamespaces} = {$NS_XMLNS => 'xmlns',
                                   $NS_XML   => 'xml'
                                  };

    $self->{InScopeNamespaceStack} = [];

    # _Parents needed for attribute vs. element fixing;
    $self->{_Parents} = [];

    $self->init( %args );
    return $self;
}

sub init {
    my $self = shift;
    my %args = @_;

    $self->{Keymap}               = $args{keymap}        if defined $args{keymap};
    $self->{RootName}             = $args{rootname}      if defined $args{rootname};
    $self->{SkipRoot}             = $args{skiproot}      if defined $args{skiproot};
    $self->{DefaultElementName}   = $args{defaultname}   if defined $args{defaultname};
    $self->{BindAttrs}            = 1                    if defined $args{bindattrs};
    $self->{Keymap}               ||= {};
    $self->{RootName}             ||= 'document';
    $self->{DefaultElementName}   ||= 'default';
    $self->{TokenReplacementChar} ||= '_';

    if ( defined $args{namespaces} ) {
        foreach my $uri ( keys( %{$args{namespaces}} )) {
            $self->{Namespaces}->{"$uri"} = $args{namespaces}->{"$uri"};
        }
    }

    # let 'em change handlers if they want.
    if ( defined $args{Handler} ) {
        $self->set_handler( $args{Handler} );
    }



    if ( defined( $args{attrmap} ) ) {
        $self->{Attrmap} = {};
        while ( my ($k, $v) = ( each( %{$args{attrmap}} ) )) {
            push @{$self->{Attrmap}->{$k}}, ref( $v ) ? @{$v} : $v;
        }
    }
    $self->{Attrmap} ||= {};

    if ( defined( $args{namespacemap} ) ) {
        $self->{Namespacemap} = {};
        while ( my ($k, $v) = ( each( %{$args{namespacemap}} ) )) {
            push @{$self->{Namespacemap}->{$k}}, ref( $v ) ? @{$v} : $v;
        }
    }
    $self->{Namespacemap} ||= {};

    if ( defined( $args{charmap} ) ) {
        $self->{Charmap} = {};
        while ( my ($k, $v) = ( each( %{$args{charmap}} ) )) {
            push @{$self->{Charmap}->{$k}}, ref( $v ) ? @{$v} : $v;
        }
    }
    $self->{Charmap} ||= {};

    # Skipelements:
    # Makes sense from an interface standpoint for the user
    # to pass an array ref, but it makes it more efficient to
    # implement if its a hash ref. Let's pull a little juju.

    my %skippers = ();
    if ( $args{skipelements} ) {
        %skippers = map { $_, 1} @{$args{skipelements}}
    }

    #warn "SKIPPPERS " . Dumper( \%args );
    $self->{Skipelements} = \%skippers;

}

sub parse_start {
    my $self = shift;
    $self->init( @_ ) if scalar @_;

    $self->start_document( {} );

    unless ( defined $self->{SkipRoot} ) {
        $self->start_element( $self->_start_details( $self->{RootName} ) );
        push @{$self->{_Parents}}, $self->{RootName};
    }
}

sub parse_end {
    my $self = shift;
    unless ( defined $self->{SkipRoot} ) {
        $self->end_element( $self->_end_details( $self->{RootName} ) );
    }

    foreach my $uri ( keys( %{$self->{DeclaredNamespaces}} )) {
        next if $uri eq $NS_XMLNS;
        next if $uri eq $NS_XML;
        next if not defined $self->{DeclaredNamespaces}->{$uri};

        $self->end_prefix_mapping({ Prefix => $self->{DeclaredNamespaces}->{$uri},
                                    NamespaceURI => $uri
                                 });
    }

    return $self->end_document();
}

sub parse {
    my $self = shift;
    my $wtf = shift || die "No Data Passed!";
    $self->init( @_ );

    my $type = $self->get_type( $wtf );
    if ( defined $type ) {
        my $processor = lc( $type ) . 'ref2SAX';
        # process the document...
        $self->parse_start;
        $self->$processor( $wtf );
        $self->parse_end;
    }
    else {
        die "Data passed must be a reference.";
    }
}

sub parse_chunk {
    my $self = shift;
    my $wtf = shift || die "No Data Passed!";
    my $type = $self->get_type( $wtf );
    if ( defined $type ) {
        my $processor = lc( $type ) . 'ref2SAX';
        $self->$processor( $wtf );
    }
    else {
        die "Data passed must be a reference.";
    }
}


sub hashref2SAX {
    my $self = shift;
    my $hashref= shift;

    my $char_data = '';

ELEMENT: foreach my $key (keys (%{$hashref} )) {
         my $value = $hashref->{$key};
         my $element_name = $self->_keymapped_name( $key );

         next if defined $self->{Skipelements}->{$element_name};


         if ( defined $self->{_Parents}->[-1] and defined $self->{Attrmap}->{$self->{_Parents}->[-1]} ) {
             foreach my $name ( @{$self->{Attrmap}->{$self->{_Parents}->[-1]}} ) {
                 next ELEMENT if $name eq $element_name;
             }
         }

         if ( defined $self->{_Parents}->[-1] and defined $self->{Charmap}->{$self->{_Parents}->[-1]} ) {
             if ( grep {$_ eq $element_name} @{$self->{Charmap}->{$self->{_Parents}->[-1]}}  ) {
                     $self->characters( {Data => $value });
                     next ELEMENT;
             }
         }

         my $type = $self->get_type( $value );

        if ( $type eq 'ARRAY' ) {
            push @{$self->{_Parents}}, $element_name;
            $self->arrayref2SAX( $value );
            pop (@{$self->{_Parents}});
        }
        elsif ( $type eq 'HASH' ) {
            # attr mojo
            my %attrs = ();
            if ( defined $self->{Attrmap}->{$element_name} ) {
                my @attr_names = ();
                ATTR: foreach my $child ( keys( %{$value} )) {
                    my $name = $self->_keymapped_name( $child );
                    if ( grep {$_ eq $name} @{$self->{Attrmap}->{$element_name}} ) {
                        if ( ref( $value->{$child} ) ) {
                           warn "Cannot use a reference value " . $value->{$child} . " for key '$child' as XML attribute\n";
                           next ATTR;
                        }

                       $attrs{$name} = $value->{$child};
                    }
                }
            }
            $self->start_element( $self->_start_details( $element_name, \%attrs ) );
            push @{$self->{_Parents}}, $element_name;
            $self->hashref2SAX( $value );
            pop (@{$self->{_Parents}});
            $self->end_element( $self->_end_details( $element_name ) );
        }
        else {
            $self->start_element( $self->_start_details( $element_name ) );
            $self->characters( {Data => $value} );
            $self->end_element( $self->_end_details( $element_name ) );
        }
    }
}

sub arrayref2SAX {
    my $self = shift;
    my $arrayref= shift;
    my $passed_name = shift || $self->{_Parents}->[-1];
    my $temp_name = $self->_keymapped_name( $passed_name );

    my $element_name;
    my $i;

ELEMENT: for ( $i = 0; $i < @{$arrayref}; $i++ ) {
        if ( ref( $temp_name ) eq 'ARRAY' ) {
            my $ntest = $temp_name->[$i] || $self->{DefaultElementName};
            if ( ref( $ntest ) eq 'CODE' ) {
                $element_name = &{$ntest}();
            }
            else {
                $element_name = $self->_keymapped_name( $ntest );
            }
        }
        else {
            $element_name = $temp_name;
        }


        next if defined $self->{Skipelements}->{$element_name};


        my $type = $self->get_type( $arrayref->[$i] );

        my $value = $arrayref->[$i];

        if ( $type eq 'ARRAY' ) {
            push @{$self->{_Parents}}, $element_name;
            $self->arrayref2SAX( $value );
            pop (@{$self->{_Parents}});
        }
        elsif ( $type eq 'HASH' ) {
            # attr mojo
            my %attrs = ();
            if ( defined $self->{Attrmap}->{$element_name} ) {
                my @attr_names = ();
                ATTR: foreach my $child ( keys( %{$value} )) {
                    my $name = $self->_keymapped_name( $child );
                    if ( grep {$_ eq $name} @{$self->{Attrmap}->{$element_name}} ) {
                        if ( ref( $value->{$child} ) ) {
                           warn "Cannot use a reference value " . $value->{$child} . " for key '$child' as XML attribute\n";
                           next ATTR;
                        }

                       $attrs{$name} = $value->{$child};
                    }
                }
            }
            $self->start_element( $self->_start_details( $element_name, \%attrs ) );
            push @{$self->{_Parents}}, $element_name;
            $self->hashref2SAX( $arrayref->[$i] );
            pop (@{$self->{_Parents}});
            $self->end_element( $self->_end_details( $element_name ) );
        }
        else {
            $self->start_element( $self->_start_details( $element_name ) );
            $self->characters( {Data => $arrayref->[$i]} );
            $self->end_element( $self->_end_details( $element_name ) );
        }
    }
}

sub get_type {
    my $self = shift;
    my $wtf = shift;

    my $type = ref( $wtf );
    if ( $type ) {
        if ( $type eq 'ARRAY' or $type eq 'HASH' or $type eq 'SCALAR') {
            return $type;
        }
        else {
            # we were passed an object, yuk.
            # props to barrie slaymaker for the tip here... mine was much fuglier. ;-)
            if ( UNIVERSAL::isa( $wtf, "HASH" ) ) {
                return 'HASH';
            }
            elsif ( UNIVERSAL::isa( $wtf, "ARRAY" ) ) {
                return 'ARRAY';
            }
            elsif ( UNIVERSAL::isa( $wtf, "SCALAR" ) ) {
                return 'SCALAR';
            }
            else {
                die "Unhandlable reference passed: $type \n";
            }
        }

    }
    else {
        return '_plain';
    }
}

###
# Interface helpers
###

sub add_namespace {
    my $self = shift;
    my %args = @_;
    unless ( defined $args{prefix} and defined $args{uri} ) {
        warn "Invalid arguments passed to add_namespace, skipping.";
        return;
    }
    $self->{Namespaces}->{"$args{uri}"} = $args{prefix};
}

sub namespacemap {
    my $self = shift;
    my %nsmap;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            %nsmap = %{$_[0]};
        }
        else {
            %nsmap = @_;
        }

        while ( my ($k, $v) = each ( %nsmap ) ) {
            if ( ref( $v ) ) {
                $self->{Namespacemap}->{$k} = $v;
            }
            else {
                $self->{Namespacemap}->{$k} = [ $v ];
            }
        }
    }

    return wantarray ? %{$self->{Namespacemap}} : $self->{Namespacemap};
}

sub add_namespacemap {
    my $self = shift;
    my %args = @_;

    foreach my $uri ( keys( %args )) {
        push @{$self->{Namespacemap}->{"$uri"}}, $args{$uri};
    }
}

sub delete_namespacemap {
    my $self = shift;
    my @mapped;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            @mapped = @{$_[0]};
        }
        else {
            @mapped = @_;
        }
        foreach my $name ( @mapped ) {
            foreach my $uri ( keys( %{$self->{Namespacemap}} )) {
                my $i;
                for ($i = 0; $i < scalar @{$self->{Namespacemap}->{$uri}}; $i++) {
                   splice @{$self->{Namespacemap}->{$uri}}, $i, 1 if $self->{Namespacemap}->{$uri}->[$i] eq $name;
                }
                delete $self->{Namespacemap}->{$uri} unless scalar @{$self->{Namespacemap}->{$uri}} > 0;
            }
        }
    }
}

sub attrmap {
    my $self = shift;
    my %attrmap;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            %attrmap = %{$_[0]};
        }
        else {
            %attrmap = @_;
        }

        while ( my ($k, $v) = each( %attrmap )) {
            if ( ref( $v ) ) {
                $self->{Attrmap}->{$k} = $v;
            }
            else {
                $self->{Attrmap}->{$k} = [ $v ];
            }
        }
    }

    return wantarray ? %{$self->{Attrmap}} : $self->{Attrmap};
}

sub add_attrmap {
    my $self = shift;
    my %attrmap;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            %attrmap = %{$_[0]};
        }
        else {
            %attrmap = @_;
        }

        while ( my ($k, $v) = each ( %attrmap ) ) {
            if ( ref( $v ) ) {
                $self->{Attrmap}->{$k} = $v;
            }
            else {
                $self->{Attrmap}->{$k} = [ $v ];
            }
        }

    }
}

sub delete_attrmap {
    my $self = shift;
    my @mapped;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            @mapped = @{$_[0]};
        }
        else {
            @mapped = @_;
        }
        foreach my $name ( @mapped ) {
            delete $self->{Attrmap}->{$name} if $self->{Attrmap}->{$name};
        }
    }
}

sub charmap {
    my $self = shift;
    my %charmap;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            %charmap = %{$_[0]};
        }
        else {
            %charmap = @_;
        }

        while ( my ($k, $v) = each( %charmap )) {
            if ( ref( $v ) ) {
                $self->{Charmap}->{$k} = $v;
            }
            else {
                $self->{Charmap}->{$k} = [ $v ];
            }
        }
    }

    return wantarray ? %{$self->{Charmap}} : $self->{Charmap};
}

sub add_charmap {
    my $self = shift;
    my %charmap;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            %charmap = %{$_[0]};
        }
        else {
            %charmap = @_;
        }

        while ( my ($k, $v) = each ( %charmap ) ) {
            if ( ref( $v ) ) {
                $self->{Charmap}->{$k} = $v;
            }
            else {
                $self->{Charmap}->{$k} = [ $v ];
            }
        }

    }
}

sub delete_charmap {
    my $self = shift;
    my @mapped;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            @mapped = @{$_[0]};
        }
        else {
            @mapped = @_;
        }
        foreach my $name ( @mapped ) {
            delete $self->{Charmap}->{$name} if $self->{Charmap}->{$name};
        }
    }
}

sub add_keymap {
    my $self = shift;
    my %keymap;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            %keymap = %{$_[0]};
        }
        else {
            %keymap = @_;
        }

        foreach my $name ( keys( %keymap )) {
            $self->{Keymap}->{$name} = $keymap{$name};
        }
    }
}

sub delete_keymap {
    my $self = shift;
    my @mapped;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            @mapped = @{$_[0]};
        }
        else {
            @mapped = @_;
        }
        foreach my $name ( @mapped ) {
            delete $self->{Keymap}->{$name} if $self->{Keymap}->{$name};
        }
    }
}

sub add_skipelements {
    my $self = shift;
    my @skippers;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            @skippers = @{$_[0]};
        }
        else {
            @skippers = @_;
        }
        foreach my $name ( @skippers ) {
            $self->{Skipelements}->{$name} = 1;
        }
    }
}

sub delete_skipelements {
    my $self = shift;
    my @skippers;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            @skippers = @{$_[0]};
        }
        else {
            @skippers = @_;
        }
        foreach my $name ( @skippers ) {
            delete $self->{Skipelements}->{$name} if $self->{Skipelements}->{$name};
        }
    }
}

sub rootname {
    my ($self, $rootname) = @_;

    # ubu: add a check to warn them if the processing has already begun?
    if ( defined $rootname ) {
        $self->{RootName} = $rootname;
    }

    return $self->{RootName};
}

sub bindattrs {
    my $self = shift;
    my $flag = shift;
    if ( defined($flag) ) {
        if ($flag == 0) {
            $self->{BindAttrs} = undef;
        }
        else {
            $self->{BindAttrs} = 1;
        }
    }

    return $self->{BindAttrs};

}

sub defaultname {
    my ($self, $dname) = @_;

    if ( defined $dname ) {
        $self->{DefaultElementName} = $dname;
    }
    return $self->{DefaultElementName};
}

sub keymap {
    my $self = shift;
    my %keymap;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            %keymap = %{$_[0]};
        }
        else {
            %keymap = @_;
        }
        $self->{Keymap} = \%keymap;
    }

    return wantarray ? %{$self->{Keymap}} : $self->{Keymap};
}

sub skipelements {
    my $self = shift;
    my @skippers;
    if ( scalar( @_ ) > 0 ) {
        if ( ref( $_[0] )) {
            @skippers = @{$_[0]};
        }
        else {
            @skippers = @_;
        }
        my %skippers = map { $_, 1} @skippers;
        $self->{Skipelements} = \%skippers;
    }

    my @skippers_out = keys %{$self->{Skipelements}} || ();

    return wantarray ? @skippers_out : \@skippers_out;
}


###
# Convenience helpers to make 'stream style' friendly
###

sub start_tag {
    my $self = shift;
    my $element_name = shift;
    my %attrs = @_;
    $self->start_element( $self->_start_details( $element_name, \%attrs ) );
    push @{$self->{_Parents}}, $element_name;

}

sub end_tag {
    my ($self, $tagname) = @_;
    $self->end_element( $self->_end_details( $tagname ) );
    pop (@{$self->{_Parents}});
}

####
# Internal Helpers
###

sub _keymapped_name {
    my ($self, $name) = @_;
    my $element_name;
    if ( defined $self->{Keymap}->{$name} ) {
        my $temp_name = $self->{Keymap}->{$name};

        if ( ref( $temp_name ) eq 'CODE' ) {
            $element_name = &{$temp_name}( $name );
        }
        else {
            $element_name = $temp_name;
        }
    }
    elsif ( defined $self->{Keymap}->{'*'} ) {
        my $temp_name = $self->{Keymap}->{'*'};

        if ( ref( $temp_name ) eq 'CODE' ) {
            $element_name = &{$temp_name}( $name );
        }
        else {
            $element_name = $temp_name;
        }
    }
    else {
        $element_name = $name;
    }
}

sub _start_details {
    my $self = shift;
    my ($element_name, $attrs) = @_;
    my %real_attrs;
    foreach my $attr (keys(%{$attrs})) {
        my $uri;
        my $prefix;
        my $qname;
        my $lname;

        if ( defined $self->{BindAttrs} ) {
            ($uri, $prefix, $qname, $lname) = $self->_namespace_fixer( $attr );
        }
        else {
            $lname = $self->_name_fixer( $attr );
            $qname = $lname;
        }

        my $key_uri = $uri || "";
        $real_attrs{"\{$key_uri\}$lname"} = {
                                             Name         => $qname,
                                             LocalName    => $lname,
                                             Prefix       => $prefix,
                                             NamespaceURI => $uri,
                                             Value => $attrs->{$attr} };

    }

    if ( scalar( keys( %{$self->{Namespaces}} )) > scalar( keys( %{$self->{DeclaredNamespaces}} )) ) {
        my @unseen_uris = grep { not defined $self->{DeclaredNamespaces}->{$_} } keys( %{$self->{Namespaces}} );
        foreach my $uri ( @unseen_uris ) {
            my $qname;
            my $prefix;
            my $lname;
            my $key_uri;
            my $ns_uri;

            # this, like the Java version of SAX2, explicitly follows production 5.2 of the
            # W3C Namespaces rec.-- specifically:
            # http://www.w3.org/TR/1999/REC-xml-names-19990114/#defaulting

            if ( $self->{Namespaces}->{$uri} eq '#default' ) {
                $qname = 'xmlns';
                $lname = 'xmlns';
                $prefix =  undef;
                $key_uri = "";
                $ns_uri = undef;
            }
            else {
                $lname = $self->{Namespaces}->{$uri};
                $prefix = 'xmlns';
                $qname = $prefix . ':' . $lname;
                #$key_uri = "";
                $key_uri = $NS_XMLNS;
                $ns_uri = $NS_XMLNS;


            }
            $real_attrs{"\{$key_uri\}$lname"} = {
                                            Name         => $qname,
                                            LocalName    => $lname,
                                            Prefix       => $prefix,
                                            NamespaceURI => $ns_uri,
                                            Value        => $uri };

            # internal
            $self->{DeclaredNamespaces}->{$uri} = $prefix;

            # fire events if needed.
            if ( defined $prefix ) {
                $self->start_prefix_mapping( { Prefix => $self->{Namespaces}->{$uri},
                                               NamespaceURI => $uri
                                             });
            }
        }
    }

    my ($uri, $prefix, $qname, $lname) = $self->_namespace_fixer( $element_name );
    my %element = (LocalName    => $lname,
                   Name         => $qname,
                   Prefix       => $prefix,
                   NamespaceURI => $uri,
                   Attributes   => \%real_attrs,
                  );

    if ( defined $uri and grep { $element_name eq $_ } @{$self->{Namespacemap}->{$uri}} ) {
        push @{$self->{InScopeNamespaceStack}}, [$uri, $prefix];
    }


    return \%element;
}

sub _end_details {
    my $self = shift;
    my ($element_name) = @_;
    my ( $uri, $prefix, $qname, $lname ) = $self->_namespace_fixer( $element_name );
    my %element = (LocalName    => $lname,
                   Name         => $qname,
                   Prefix       => $prefix,
                   NamespaceURI => $uri,
                  );

    if ( defined $uri and grep { $element_name eq $_ } @{$self->{Namespacemap}->{$uri}} ) {
         pop @{$self->{InScopeNamespaceStack}};
    }

    return \%element;
}

sub _namespace_fixer {
    my ( $self, $node_name ) = @_;
    my $prefix;
    my $qname;
    my $uri;
    my $lname = $self->_name_fixer( $node_name );

    foreach my $ns ( keys( %{$self->{Namespacemap}} )) {
        if ( grep { $node_name eq $_ } @{$self->{Namespacemap}->{"$ns"}} ) {
            $uri = $ns;
        }
    }

    if ( defined( $uri ) ) {
        $prefix = $self->{Namespaces}->{"$uri"};
        if ( $prefix eq '#default' ) {
            $prefix = undef;
        }
        else {
            $qname = $prefix . ':' . $lname;
        }
        $qname ||= $lname;
    }
    else {
        if ( defined $self->{InScopeNamespaceStack}->[-1] ) {
            ($uri, $prefix) = @{$self->{InScopeNamespaceStack}->[-1]};
            if ( $prefix ) {
                $qname = $prefix . ':' . $lname;
            }
        }
    }
    $qname ||= $lname;
    return ($uri, $prefix, $qname, $lname);
}


sub _name_fixer {
    my ($self, $name) = @_;
    # UNICODE WARNING
    $name =~ s|^[^a-zA-Z_:]{1}|_|g;
    $name =~ tr|a-zA-Z0-9._:-|_|c;

    return $name;
}

1;
__END__