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

   $bool = $self->delete( $element_obj );

   $bool = $self->insert( $element_obj );

   $hash_ref = $self->load_files( @paths );

   $hash_ref = $self->select;

   $bool = $self->update( $element_obj );

# @(#)$Id: XML.pm 597 2009-06-20 22:05:52Z pjf $

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

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

use CatalystX::Usul::File::HashMerge;
use Class::C3;
use Hash::Merge qw(merge);

__PACKAGE__->config( extn => q(.xml), lang => q(), path => q(), _dtd => [] );

__PACKAGE__->mk_accessors( qw(extn lang path schema _arrays _dtd) );

my $cache = {};

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

   return $self->_delete( $element_obj, $self->_validate_params );
}

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

   my ($path, $element) = $self->_validate_params;

   $path->touch;

   # TODO: Add _arrays attributes from schema definition
   if ($self->_is_array( $element ) and not $self->_is_in_dtd( $element )) {
      push @{ $self->_dtd }, '<!ELEMENT '.$element.' (ARRAY)*>';
   }

   return $self->_write( 0, $element_obj, $path, $element );
}

sub load_files {
   my ($self, @paths) = @_; return $self->_load_files( @paths );
}

sub select {
   my $self = shift; my ($path, $element) = $self->_validate_params;

   my @paths = ( $path );

   push @paths, $self->_make_lang_path( $path ) if ($self->lang);

   my $data = $self->_load_files( @paths );

   return exists $data->{ $element } ? $data->{ $element } : {};
}

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

   return $self->_write( 1, $element_obj, $self->_validate_params );
}

# Private methods

sub _delete {
   my ($self, $element_obj, $path, $element) = @_;

   my $name    = delete $element_obj->{name};
   my ($data)  = $self->_read_file( $path );
   my $updated = 0;

   if (exists $data->{ $element } and exists $data->{ $element }->{ $name }) {
      delete $data->{ $element }->{ $name };
      $self->_write_file( $path, $data );
      $updated = 1;
   }

   if ($self->lang) {
      my $lang_path = $self->_make_lang_path( $path );

      ($data) = $self->_read_file( $lang_path );

      if (    exists $data->{ $element }
          and exists $data->{ $element }->{ $name }) {
         delete $data->{ $element }->{ $name };
         $self->_write_file( $lang_path, $data );
         $updated = 1;
      }
   }

   unless ($updated) {
      $self->throw( error => 'File [_1] element [_2] not updated',
                    args  => [ $path, $name ] );
   }

   return $updated;
}

sub _delete_cache {
   my ($self, $key) = @_; delete $cache->{ $key }; return;
}

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

   $self->_dtd_parse_reset;

   return unless ($data);

   while ($data =~ s{ ( <! [^<>]+ > ) }{}msx) {
      push @{ $self->_dtd }, $1; $self->_dtd_parse_line( $1 );
   }

   return $data;
}

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

   if ($data =~ m{ \A <!ELEMENT \s+ (\w+) \s+ \(
                                            \s* ARRAY \s* \) \*? \s* > \z }imsx) {
      $self->_arrays->{ $1 } = 1;
   }

   return;
}

sub _dtd_parse_reset {
   my $self = shift; $self->_arrays( {} ); $self->_dtd( [] ); return;
}

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

   return 0;
}

sub _is_in_dtd {
   my ($self, $candidate) = @_; my %elements;

   my $pattern = '<!ELEMENT \s+ (\w+) \s+ \( \s* ARRAY \s* \) \*? \s* >';

   $elements{ $_ } = 1 for (grep { m{ \A $pattern \z }msx } @{ $self->_dtd });

   return exists $elements{ $candidate };
}

sub _load_files {
   my ($self, @paths) = @_; my ($cached, $data, $key, $mtime, $path);

   return {} unless ($paths[0]);

   my $newest = 0; my $ref = {};

   for $path (@paths) {
      my $pathname = $path->pathname;

      $key .= $key ? q(~).$pathname : $pathname;

      if ($cached = $cache->{ $pathname }) { $mtime = $cached->{mtime} }
      else { $mtime = $path->stat->{mtime} || 0 }

      $newest = $mtime if ($mtime > $newest);
   }

   $cached = $cache->{ $key };

   if (not $cached or $cached->{mtime} < $newest) {
      for $path (@paths) {
         ($data) = $self->_read_file( $path );

         next unless ($data);

         for (keys %{ $data }) {
            $ref->{ $_ } = exists $ref->{ $_ }
                         ? merge( $ref->{ $_ }, $data->{ $_ } )
                         : $data->{ $_ };
         }
      }

      $self->_set_cache( $key, $ref, $newest );
   }
   else { $ref = $cached->{data} }

   return $ref;
}

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

   my $pathname = $path->pathname; my $extn = $self->extn;

   return $pathname.q(_).$self->lang unless ($pathname =~ m{ $extn \z }mx);

   my $file = $self->basename( $pathname, $extn ).q(_).$self->lang.$extn;

   return $self->io( $self->catfile( $self->dirname( $pathname ), $file ) );
}

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

   $self->throw( error => 'Method _read_file not overridden in [_1]',
                 args  => [ ref $self ] );
   return;
}

sub _read_file_with_locking {
   my ($self, $path, $coderef) = @_; my ($data, $e);

   my $pathname = $path->pathname;

   $self->lock->set( k => $pathname );

   my $res   = $cache->{ $pathname };
   my $mtime = $path->stat->{mtime};

   if (not $res or $res->{mtime} < $mtime) {
      $data = eval { $coderef->() };

      if ($e = $self->catch) {
         $self->lock->reset( k => $pathname ); $self->throw( $e );
      }

      $self->_set_cache( $pathname, $data, $mtime );

      $self->log_debug( "Reread config $pathname" ) if ($self->debug);
   }
   else {
      $data = $res->{data}; $self->_dtd( $res->{dtd} );

      $self->log_debug( "Cached config $pathname" ) if ($self->debug);
   }

   $self->lock->reset( k => $pathname );

   return ($data, $mtime);
}

sub _set_cache {
   my ($self, $key, $data, $mtime) = @_;

   $cache->{ $key } = { data => $data, dtd => $self->_dtd, mtime => $mtime };
   return;
}

sub _validate_params {
   my $self = shift; my ($elem, $path, $schema);

   $self->throw( 'No schema specified'    ) unless ($schema = $self->schema);
   $self->throw( 'No file path specified' ) unless ($path = $self->path);
   $self->throw( 'No element specified'   ) unless ($elem = $schema->element);

   return ($path, $elem);
}

sub _write {
   my ($self, $overwrite, $element_obj, $path, $element) = @_;

   my $schema    = $self->schema;
   my $condition = sub { !$schema->lang_dep || !$schema->lang_dep->{ $_[0] } };
   my $updated   = $self->_write_on_condition( $overwrite, $element_obj,
                                               $path, $element, $condition );

   if ($self->lang) {
      my $lpath  = $self->_make_lang_path( $path );
      $condition = sub { $schema->lang_dep && $schema->lang_dep->{ $_[0] } };
      my $res    = $self->_write_on_condition( $overwrite, $element_obj,
                                               $lpath, $element, $condition );
      $updated ||= $res;
   }

   $self->throw( 'Nothing updated' ) if ($overwrite and not $updated);

   return $updated;
}

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

   $self->throw( error => 'Method _write_file not overridden in [_1]',
                 args  => [ ref $self ] );
   return;
}

sub _write_file_with_locking {
   my ($self, $path, $coderef) = @_; my $e;

   my $pathname = $path->pathname;

   $self->lock->set( k => $pathname );

   my $wtr  = $path->perms( oct q(0664) )->atomic;
   my $data = eval { $coderef->( $wtr ) };

   if ($e = $self->catch) {
      $wtr->delete; $self->lock->reset( k => $pathname );
      $self->throw( $e );
   }

   $wtr->close;
   $self->_delete_cache( $pathname );
   $self->lock->reset( k => $pathname );
   return;
}

sub _write_on_condition {
   my ($self, $overwrite, $element_obj, $path, $element, $condition) = @_;

   my $name   = $element_obj->name;
   my ($data) = $self->_read_file( $path );

   if (not $overwrite and exists $data->{ $element }->{ $name }) {
      $self->throw( error => 'File [_1] element [_2] already exists',
                    args  => [ $path->pathname, $name ] );
   }

   my $updated = CatalystX::Usul::File::HashMerge->merge
      ( $element_obj, \$data->{ $element }->{ $name }, $condition );

   $self->_write_file( $path, $data ) if ($updated);

   return $updated;
}

1;

__END__

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