CatalystX::Usul::File::Storage::XML::Bare - Read/write XML data storage model

   package CatalystX::Usul::File::Storage;

   use parent qw(CatalystX::Usul);

   __PACKAGE__->config( class => q(XML::Bare) );

   sub new {
      my ($self, $app, $attrs) = @_; $attrs ||= {};

      my $class = $attrs->{class} || $self->config->{class};

      if (q(+) eq substr $class, 0, 1) { $class = substr $class, 1 }
      else { $class = __PACKAGE__.q(::).$class }

      $self->ensure_class_loaded( $class );

      return $class->new( $app, $attrs );
   }

# @(#)$Id: Bare.pm 576 2009-06-09 23:23:46Z pjf $

package CatalystX::Usul::File::Storage::XML::Bare;

use strict;
use warnings;
use version; our $VERSION = qv( sprintf '0.3.%d', q$Rev: 576 $ =~ /\d+/gmx );
use parent qw(CatalystX::Usul::File::Storage::XML);

use XML::Bare;

__PACKAGE__->config( root_name => q(config) );

__PACKAGE__->mk_accessors( qw(root_name) );

my $PADDING = q(  );

# Private methods

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

   my $method = sub {
      my $data;
      $data = $self->_dtd_parse( $path->all );
      $data = XML::Bare->new( text => $data )->parse() || {};
      $data = $data->{ $self->root_name } || {};
      $self->_read_filter( $self->_arrays || {}, $data );
      return $data;
   };

   return $self->_read_file_with_locking( $path, $method );
}

sub _write_file {
   my ($self, $path, $data) = @_;

   unless (-f $path->pathname) {
      $self->throw( error => 'File [_1] not found',
                    args  => [ $path->pathname ] );
   }

   my $method = sub {
      my $wtr = shift;
      $wtr->println( @{ $self->_dtd } ) if ($self->_dtd->[ 0 ]);
      $wtr->print(  $self->_write_filter( 0, $self->root_name, $data ) );
      return $data;
   };

   return $self->_write_file_with_locking( $path, $method );
}

# Private methods

sub _read_filter {
   # Turn the structure returned by XML::Bare into one returned by XML::Simple
   my ($self, $arrays, $data) = @_; my ($hash, $value);

   if (ref $data eq q(ARRAY)) {
      for my $key (0 .. $#{ $data }) {
         if (ref $data->[ $key ] eq q(HASH)
             && defined ($value = $data->[ $key ]->{value})
             && $value !~ m{ \A [\n\s]+ \z }mx) {
            # Coerce arrays from single scalars. Array list given by the DTD
            if ($arrays->{ $key }) { $data->[ $key ] = [ $value ] }
            else { $data->[ $key ] = $value }

            next;
         }

         $self->_read_filter( $arrays, $data->[ $key ] ); # Recurse
      }
   }
   elsif (ref $data eq q(HASH)) {
      for my $key (keys %{ $data }) {
         if (ref $data->{ $key } eq q(HASH)
             && defined ($value = $data->{ $key }->{value})
             && $value !~ m{ \A [\n\s]+ \z }mx) {
            # Coerce arrays from single scalars. Array list given by the DTD
            if ($arrays->{ $key }) { $data->{ $key } = [ $value ] }
            else { $data->{ $key } = $value }

            next;
         }

         $self->_read_filter( $arrays, $data->{ $key } ); # Recurse

         # Turn arrays of hashes with a name attribute into hash keyed by name
         if (ref $data->{ $key } eq q(ARRAY)
             && ($value = $data->{ $key }->[ 0 ])
             && ref $value eq q(HASH)
             && exists $value->{name}) {
            $hash = {};

            for my $ref (@{ $data->{ $key } }) {
               my $name = delete $ref->{name}; $hash->{ $name } = $ref;
            }

            $data->{ $key } = $hash;
         }
      }

      delete $data->{_pos} if (exists $data->{_pos});

      if (exists $data->{value} && $data->{value} =~ m{ \A [\n\s]+ \z }mx) {
         delete $data->{value};
      }
   }

   return;
}

sub _write_filter {
   my ($self, $level, $element, $data) = @_; my $xml = q();

   my $padding = $PADDING x $level;

   if (ref $data eq q(ARRAY)) {
      for (sort @{ $data }) {
         $xml .= $padding.q(<).$element.q(>).$_.q(</).$element.q(>)."\n";
      }
   }
   elsif (ref $data eq q(HASH)) {
      $padding = $PADDING x ($level + 1);

      for my $key (sort keys %{ $data }) {
         my $value = $data->{ $key };

         if (ref $value eq q(HASH)) {
            for (sort keys %{ $value }) {
               $xml .= $padding.q(<).$key.q(>)."\n";
               $xml .= $padding.$PADDING.q(<name>).$_.q(</name>)."\n";
               $xml .= $self->_write_filter( $level + 1, q(), $value->{ $_ } );
               $xml .= $padding.q(</).$key.q(>)."\n";
            }
         }
         else { $xml .= $self->_write_filter( $level + 1, $key, $value ) }
      }
   }
   elsif ($element) {
      $xml .= $padding.q(<).$element.q(>).$data.q(</).$element.q(>)."\n";
   }

   if ($level == 0 && $element) {
      $xml = q(<).$element.q(>)."\n".$xml.q(</).$element.q(>)."\n";
   }

   return $xml;
}

1;

__END__

# Local Variables:
# mode: perl
# tab-width: 3
# End: