package SIAM::Driver::Simple;

use warnings;
use strict;

use YAML ();
use Log::Handler;
use Digest::MD5 ();

=head1 NAME


SIAM::Driver::Simple - a reference implementation of SIAM Driver


=cut


=head1 SYNOPSIS

The driver does not connect to any external databases. Instead, it reads
all the SIAM objects from its YAML data file.

The top level element in the data file is expected to be an array of
objects that are contained in the SIAM root. The following object
classes are expected to be contained by the root object:

=over 4

=item * SIAM::Contract

=item * SIAM::AccessScope

=item * SIAM::User

=back

Each object definition may have an entry with the key C<_contains_>
which points to an array of contained objects. For example, an
C<SIAM::Contract> object is expected to contain one or more
C<SIAM::Service> objects.

All other keys in the object entry define the object attributes. The
values are expected to be strings and numbers. The data file should
define all the attributes, including C<object.id> and C<object.class>.

See the file I<t/driver-simple.data.yaml> in SIAM package distribution
for reference.


=head1 MANDATORY METHODS

The following methods are required by C<SIAM::Documentation::DriverSpec>.


=head2 new

Instantiates a new driver object. The method expects a driver object and a hash
reference containing the attributes, as follows:

=over 4

=item * datafile

Full path of the YAML data file which defines all the objects for this driver.

=item * logger

Logger configuration as specified in C<Log::Handler> description.

=back

=cut

sub new
{
    my $class = shift;
    my $drvopts = shift;

    my $self = {};
    bless $self, $class;

    $self->{'config'} = $drvopts;
    
    foreach my $param ('datafile', 'logger')
    {
        if( not defined($drvopts->{$param}) )
        {
            print STDERR 
                ('Missing mandatiry parameter ' . $param .
                 ' in SIAM::Driver::Simple->new()');
            return undef;
        }
    }

    $self->{'logger'} = new Log::Handler(%{$drvopts->{'logger'}});

    if( not -r $self->{'config'}{'datafile'} )
    {
        $self->error('Data file is not readable: ' .
                     $self->{'config'}{'datafile'});
        return undef;
    }

    $self->{'errmsg'} = '';
    
    return $self;    
}


=head2 connect

Reads the YAML data file

=cut

sub connect
{
    my $self = shift;

    my $data = eval { YAML::LoadFile($self->{'config'}{'datafile'}) };
    if( $@ )
    {
        $self->error('Cannot load YAML data from ' .
                     $self->{'config'}{'datafile'} . ': ' . $@);
        return undef;
    }
    
    if( ref($data) ne 'ARRAY' )
    {
        $self->error('Top level is not a sequence in ' .
                     $self->{'config'}{'datafile'});
        return undef;
    }

    $self->{'objects'} = {};
    $self->{'attr_index'} = {};
    $self->{'contains'} = {};
    $self->{'container'} = {};
    $self->{'data_ready'} = 1;
    
    foreach my $obj (@{$data})
    {
        $self->_import_object($obj, 'SIAM.ROOT');
    }
    
    return $self->{'data_ready'};
}

# recursively import the objects

sub _import_object
{
    my $self = shift;
    my $obj = shift;
    my $container_id = shift;

    my $id = $obj->{'object.id'};
    if( not defined($id) )
    {
        $self->error($container_id .
                     ' contains an object without "object.id"' );
        $self->{'data_ready'} = 0;
        return;
    }

    my $class = $obj->{'object.class'};
    if( not defined($class) )
    {
        $self->error('Object ' . $id . ' does not have "object.class"' );
        $self->{'data_ready'} = 0;
        return;
    }
        
    # duplicate all attributes except "_contains_"

    my $dup = {};
    while( my ($key, $val) = each %{$obj} )
    {
        if( $key ne '_contains_' )
        {
            $dup->{$key} = $val;
            $self->{'attr_index'}{$class}{$container_id}{$key}{$val}{$id} = 1;
        }
    }
    
    $self->{'objects'}{$id} = $dup;    
    $self->{'contains'}{$container_id}{$class}{$id} = 1;
    $self->{'container'}{$id} = $container_id;
        
    if( defined($obj->{'_contains_'}) )
    {
        foreach my $contained_obj (@{$obj->{'_contains_'}})
        {
            $self->_import_object($contained_obj, $id);
        }
    }
}


=head2 disconnect

Disconnects the driver from its underlying databases.

=cut

sub disconnect
{
    my $self = shift;
    
    delete $self->{'objects'};
    delete $self->{'attr_index'};
    delete $self->{'contains'};
    delete $self->{'container'};
    $self->{'data_ready'} = 0;
}


=head2 fetch_attributes

 $status = $driver->fetch_attributes($attrs);

Retrieve the object by ID and populate the hash with object attributes.

=cut

sub fetch_attributes
{
    my $self = shift;
    my $obj = shift;

    my $id = $obj->{'object.id'};
    if( not defined($id) )
    {
        $self->error('object.id is not specified in fetch_attributes' );      
        return undef;
    }
    
    if( not defined($self->{'objects'}{$id}) )
    {
        $self->error('Object not found: ' . $id );      
        return undef;
    }

    while( my($key, $val) = each %{$self->{'objects'}{$id}} )
    {
        $obj->{$key} = $val;
    }
    
    return 1;
}
    

=head2 fetch_computable

  $value = $driver->fetch_computable($id, $key);

Retrieve a computable. Return empty string if unsupported.

=cut

sub fetch_computable
{
    my $self = shift;
    my $id = shift;
    my $key = shift;

    my $obj = $self->{'objects'}{$id};
    if( not defined($obj) )
    {
        $self->error('Object not found: ' . $id );
        return undef;
    }

    if( $key eq 'contract.content_md5hash' )
    {
        if( $obj->{'object.class'} eq 'SIAM::Contract' )
        {
            my $md5 = new Digest::MD5;
            $self->_object_content_md5($id, $md5);
            return $md5->hexdigest();
        }
    }
    
    return '';
}
            

# recursively add all contained objects for MD5 calculation
sub _object_content_md5
{
    my $self = shift;
    my $id = shift;
    my $md5 = shift;

    my $obj = $self->{'objects'}{$id};
    
    foreach my $attr (sort keys %{$obj})
    {
        $md5->add($attr . '//' . $obj->{$attr});
    }

    if( defined($self->{'contains'}{$id}) )
    {
        foreach my $class (sort keys %{$self->{'contains'}{$id}})
        {
            foreach my $contained_id (sort
                                      keys %{$self->{'contains'}{$id}{$class}})
            {
                $self->_object_content_md5($contained_id, $md5);
            }
        }        
    }
}
    


=head2 fetch_contained_object_ids

   $ids = $driver->fetch_contained_object_ids($id, 'SIAM::Contract', {
       'match_attribute' => [ 'object.access_scope_id',
                              ['SCOPEID01', 'SCOPEID02'] ]
      }
     );

Retrieve the contained object IDs.

=cut

sub fetch_contained_object_ids
{
    my $self = shift;
    my $container_id = shift;
    my $class = shift;
    my $options = shift;

    my $ret = [];

    if( defined($options) )
    {
        if( defined($options->{'match_attribute'}) )
        {
            my ($filter_attr, $filter_val) = @{$options->{'match_attribute'}};
            
            foreach my $val (@{$filter_val})                
            {
                push(@{$ret}, 
                     keys %{$self->{'attr_index'}{$class}{$container_id}{
                         $filter_attr}{$val}});
            }

            return $ret;
        }
    }
    
    if( defined($self->{'contains'}{$container_id}{$class}) )
    {
        push(@{$ret}, keys %{$self->{'contains'}{$container_id}{$class}});
    }

    return $ret;
}



=head2 fetch_contained_classes

  $classes = $driver->fetch_contained_classes($id);

Returns arrayref with class names.

=cut

sub fetch_contained_classes
{
    my $self = shift;
    my $id = shift;

    my $ret = [];
    if( defined($self->{'contains'}{$id}) )
    {
        foreach my $class (sort keys %{$self->{'contains'}{$id}})
        {
            push(@{$ret}, $class);
        }
    }
    return $ret;
}


=head2 fetch_container

  $attr = $driver->fetch_container($id);

Retrieve the container ID and class.

=cut

sub fetch_container
{
    my $self = shift;
    my $id = shift;

    my $container_id = $self->{'container'}{$id};
    if( not defined($container_id) )
    {
        return undef;
    }

    my $ret = {'object.id' => $container_id};
    if( $container_id ne 'SIAM.ROOT' )
    {
        $ret->{'object.class'} =
            $self->{'objects'}{$container_id}{'object.class'};
    }
    
    return $ret;
}


=head2 errmsg

Returns the last error message.

=cut

sub errmsg {shift->{'errmsg'}}





=head1 ADDITIONAL METHODS

The following methods are not in the Specification.


=head2 debug

Prints a debug message to the logger

=cut

sub debug
{
    my $self = shift;
    my $msg = shift;
    
    $self->{'logger'}->debug($msg);
}


=head2 error

Prints an error message to the logger. Also saves the message for errmsg();

=cut

sub error
{
    my $self = shift;
    my $msg = shift;
    
    $self->{'logger'}->error($msg);
    $self->{'errmsg'} = $msg;
}


=head2 clone_data

  SIAM::Driver::Simple->clone_data($siam, $fh,
                                   {'SIAM::Contract' => 'CTRT000[12]'});

The method takes a SIAM object, a write file handle, and optional hashref with
filters. The method walks through the SIAM data and produces a YAML data
file suitable for use by C<SIAM::Driver::Simple>. The method is usable
for producing a test data out of productive system.

The third argument, if present, defines regular expressions to filter
the object IDs. Keys are object classes, and values are regular
expressions which would be matched against object IDs.

=cut

sub clone_data
{
    my $class = shift;
    my $siam = shift;
    my $outfh = shift;
    my $filters = shift;

    my $data =
        SIAM::Driver::Simple->_retrieve_object_data($siam, $filters);
    
    print $outfh YAML::Dump($data);

    return 1;
}

# recursively walk the objects
    
sub _retrieve_object_data
{
    my $class = shift;
    my $obj = shift;
    my $filters = shift;

    my $ret = {};

    if( not $obj->is_root() )
    {
        my $attrs = $obj->attributes();
        while(my($key, $val) = each %{$attrs})
        {
            $ret->{$key} = $val;
        }
    }

    my $contained_data = [];
    my $classes = $obj->_driver->fetch_contained_classes($obj->id);
    foreach my $objclass ( @{$classes} )
    {
        my $re;
        if( defined($filters) and defined($filters->{$objclass}) )
        {
            $re = $filters->{$objclass};
        }

        my $objects = $obj->get_contained_objects($objclass);
        foreach my $contained_obj (@{$objects})
        {
            if( not defined($re) or
                $contained_obj->id() =~ $re )
            {
                push(@{$contained_data}, 
                     SIAM::Driver::Simple->_retrieve_object_data
                     ($contained_obj, $filters));
            }
        }
    }

    if( scalar(@{$contained_data}) > 0 )
    {
        if( $obj->is_root() )
        {
            return $contained_data;
        }
        else
        {
            $ret->{'_contains_'} = $contained_data;
        }
    }

    return $ret;
}
                     



=head1 SEE ALSO

L<SIAM::Documentation::DriverSpec>, L<YAML>, L<Log::Handler>

=cut

1;

# Local Variables:
# mode: cperl
# indent-tabs-mode: nil
# cperl-indent-level: 4
# cperl-continued-statement-offset: 4
# cperl-continued-brace-offset: -4
# cperl-brace-offset: 0
# cperl-label-offset: -2
# End:
