package Config::Model::ObjTreeScanner;

use 5.20.0;
use strict;
use warnings;

use Config::Model::Exception;
use Scalar::Util qw/blessed/;
use Log::Log4perl qw(get_logger :levels);
use Carp qw/carp croak confess cluck/;
use Carp::Assert::More;

use feature qw/postderef signatures/;
no warnings qw/experimental::signatures experimental::postderef/;

my $logger = get_logger("ObjTreeScanner");

my @value_cb =
    map { $_ . '_value_cb' } qw/boolean dir enum file string uniline integer number reference/;

sub new ($type, %args) {
    my $self = { auto_vivify => 1, check => 'yes' };
    bless $self, $type;

    $self->{leaf_cb} = delete $args{leaf_cb}
        or croak __PACKAGE__, "->new: missing leaf_cb parameter";

    # TODO: switch to warning in 2027
    if (delete $args{fallback}) {
        my ($package, $filename, $line) = caller;
        $logger->info("fallback parameter is deprecated. Called from $filename:$line");
    }

    # we may use leaf_cb
    $self->create_default_callbacks();

    # get all call_backs
    foreach my $param (
        qw/check node_element_cb hash_element_cb
        list_element_cb check_list_element_cb node_content_cb
        node_content_hook list_element_hook hash_element_hook
        auto_vivify up_cb/, @value_cb
        ) {
        $self->{$param} = $args{$param} if defined $args{$param};
        delete $args{$param};    # may exists but be undefined
        croak __PACKAGE__, "->new: missing $param parameter"
            unless defined $self->{$param};
    }

    # this parameter is optional and does not need a fallback
    $self->{node_dispatch_cb} = delete $args{node_dispatch_cb} || {};

    croak __PACKAGE__, "->new: node_dispatch_cb is not a hash ref"
        unless ref( $self->{node_dispatch_cb} ) eq 'HASH';

    croak __PACKAGE__, "->new: unexpected check: $self->{check}"
        unless $self->{check} =~ /yes|no|skip/;

    croak __PACKAGE__, "->new: unexpected parameter: ", join( ' ', keys %args )
        if scalar %args;

    return $self;
}

# internal
sub create_default_callbacks ($self) {
    foreach my $item (qw/node_content_hook hash_element_hook list_element_hook/) {
        $self->{$item} = sub { };
    }

    my $node_content_cb = sub {
        my ( $scanner, $data_r, $node, @elements ) = @_;
        foreach my $item (@elements) { $scanner->scan_element( $data_r, $node, $item ) };
    };

        my $node_element_cb = sub {
            my ( $scanner, $data_r, $node, $element_name, $key, $next_node ) = @_;
            $scanner->scan_node( $data_r, $next_node );
        };

        my $hash_element_cb = sub {
            my ( $scanner, $data_r, $node, $element_name, @keys ) = @_;
            foreach my $item (@keys) { $scanner->scan_hash( $data_r, $node, $element_name, $item ) };
        };

        $self->{list_element_cb} = $hash_element_cb;
        $self->{hash_element_cb} = $hash_element_cb;
        $self->{node_element_cb} = $node_element_cb;
        $self->{node_content_cb} = $node_content_cb;
        $self->{up_cb}           = sub { };            # do nothing

    my $l = $self->{string_value_cb} ||= $self->{leaf_cb};

        foreach my $cb (@value_cb, "check_list_element_cb") {
            $self->{$cb} ||= $l;
    }

    return;
}

sub scan_node {
    my ( $self, $data_r, $node ) = @_;

    #print "scan_node ",$node->name,"\n";
    # get all elements according to catalog

    Config::Model::Exception::Internal->throw( error => "'$node' is not a Config::Model object" )
        unless blessed($node)
        and $node->isa("Config::Model::AnyThing");

    # skip exploration of warped out node
    if ( $node->isa('Config::Model::WarpedNode') ) {
        $node = $node->get_actual_node;
        return unless defined $node;
    }

    my $config_class     = $node->config_class_name;
    my $node_dispatch_cb = $self->{node_dispatch_cb}{$config_class};

    my $actual_cb = $node_dispatch_cb || $self->{node_content_cb};

    my @element_list = $node->get_element_name( check => $self->{check} );

    $self->{node_content_hook}->( $self, $data_r, $node, @element_list );

    # we could add here a "last element" call-back, but it's not
    # very useful if the last element is a hash.
    $actual_cb->( $self, $data_r, $node, @element_list );

    $self->{up_cb}->( $self, $data_r, $node );
    return;
}

sub scan_element {
    my ( $self, $data_r, $node, $element_name ) = @_;

    my $element_type = $node->element_type($element_name);

    my $autov = $self->{auto_vivify};

    #print "scan_element $element_name ";
    if ( $element_type eq 'hash' ) {

        #print "type hash\n";
        my @keys = $self->get_keys( $node, $element_name );

        # if hash element grab keys and perform callback
        $self->{hash_element_hook}->( $self, $data_r, $node, $element_name, @keys );
        $self->{hash_element_cb}->( $self, $data_r, $node, $element_name, @keys );
    }
    elsif ( $element_type eq 'list' ) {

        #print "type list\n";
        my @keys = $self->get_keys( $node, $element_name );
        $self->{list_element_hook}->( $self, $data_r, $node, $element_name, @keys );
        $self->{list_element_cb}->( $self, $data_r, $node, $element_name, @keys );
    }
    elsif ( $element_type eq 'check_list' ) {

        #print "type list\n";
        my $cl_elt = $node->fetch_element( name => $element_name, check => $self->{check} );
        $self->{check_list_element_cb}->( $self, $data_r, $node, $element_name, undef, $cl_elt );
    }
    elsif ( $element_type eq 'node' ) {

        #print "type object\n";
        # avoid auto-vivification
        my $next_obj =
            ( $autov or $node->is_element_defined($element_name) )
            ? $node->fetch_element( name => $element_name, check => $self->{check} )
            : undef;

        # if obj element, cb
        $self->{node_element_cb}->( $self, $data_r, $node, $element_name, undef, $next_obj );
    }
    elsif ( $element_type eq 'warped_node' ) {

        #print "type warped\n";
        my $next_obj =
            ( $autov or $node->is_element_defined($element_name) )
            ? $node->fetch_element( name => $element_name, check => $self->{check} )
            : undef;
        $self->{node_element_cb}->( $self, $data_r, $node, $element_name, undef, $next_obj ) if $next_obj;
    }
    elsif ( $element_type eq 'leaf' ) {
        my $next_obj = $node->fetch_element( name => $element_name, check => $self->{check} );
        my $type = $next_obj->value_type;
        return unless $type;
        my $cb_name = $type . '_value_cb';
        my $cb      = $self->{$cb_name};
        croak "scan_element: No call_back specified for '$cb_name'"
            unless defined $cb;
        $cb->( $self, $data_r, $node, $element_name, undef, $next_obj );
    }
    else {
        croak "Unexpected element_type: $element_type";
    }
    return;
}

sub scan_hash {
    my ( $self, $data_r, $node, $element_name, $key ) = @_;

    assert_like( $node->element_type($element_name), qr/(hash|list)/ );

    #print "scan_hash ",$node->name," element $element_name key $key ";
    my $item = $node->fetch_element( name => $element_name, check => $self->{check} );

    my $cargo_type = $item->cargo_type($element_name);
    my $next_obj = $item->fetch_with_id( index => $key, check => $self->{check} );

    if ( $cargo_type =~ /node$/ ) {

        #print "type object or warped\n";
        $self->{node_element_cb}->( $self, $data_r, $node, $element_name, $key, $next_obj );
    }
    elsif ( $cargo_type eq 'leaf' ) {
        my $cb_name = $next_obj->value_type . '_value_cb';
        my $cb      = $self->{$cb_name};
        croak "scan_hash: No call_back specified for '$cb_name'"
            unless defined $cb;
        $cb->( $self, $data_r, $node, $element_name, $key, $next_obj );
    }
    else {
        croak "Unexpected cargo_type: $cargo_type";
    }
    return;
}

sub scan_list {
    goto &scan_hash;
}

sub get_keys {
    my ( $self, $node, $element_name ) = @_;

    my $element_type = $node->element_type($element_name);
    my $item = $node->fetch_element( name => $element_name, check => $self->{check} );

    return $item->fetch_all_indexes
        if $element_type eq 'hash'
        || $element_type eq 'list';

    Config::Model::Exception::Internal->throw(
        error  => "called get_keys on non hash or non list" . " element $element_name",
        object => $node
    );

    return;
}

1;

# ABSTRACT: Scan config tree and perform call-backs for each element or node

__END__

=head1 SYNOPSIS

 use Config::Model ;

 # define configuration tree object
 my $model = Config::Model->new ;
 $model ->create_config_class (
    name => "MyClass",
    element => [
        [qw/foo bar/] => {
            type => 'leaf',
            value_type => 'string'
        },
        baz => {
            type => 'hash',
            index_type => 'string' ,
            cargo => {
                type => 'leaf',
                value_type => 'string',
            },
        },

    ],
 ) ;

 my $inst = $model->instance(root_class_name => 'MyClass' );

 my $root = $inst->config_root ;

 # put some data in config tree the hard way
 $root->fetch_element('foo')->store('yada') ;
 $root->fetch_element('bar')->store('bla bla') ;
 $root->fetch_element('baz')->fetch_with_id('en')->store('hello') ;

 # put more data the easy way
 my $steps = 'baz:fr=bonjour baz:hr="dobar dan"';
 $root->load( steps => $steps ) ;

 # define leaf call back
 my $disp_leaf = sub {
      my ($scanner, $data_ref, $node,$element_name,$index, $leaf_object) = @_ ;
      $$data_ref .= "disp_leaf called for '". $leaf_object->name.
	"' value '".$leaf_object->fetch."'\n";
    } ;

 # simple scanner, (print all values)
 my $scan = Config::Model::ObjTreeScanner-> new (
   leaf_cb => $disp_leaf, # only mandatory parameter
 ) ;

 my $result = '';
 $scan->scan_node(\$result, $root) ;
 print $result ;

=head1 DESCRIPTION

This module creates an object that explores (depth first) a
configuration tree.

For each part of the configuration tree, ObjTreeScanner object calls
one of the subroutine reference passed during construction. (a call-back
or a hook)

Call-back and hook routines are called:

=over

=item *

For each node containing elements (including root node)

=item *

For each element of a node. This element can be a list, hash, node or
leaf element.

=item *

For each item contained in a node, hash or list. This item can be a
leaf or another node.

=back

To continue the exploration, these call-backs must also call the
scanner. (i.e. perform another call-back). In other words the user's
subroutine and the scanner play a game of ping-pong until the tree is
completely explored.

Hooks routines are not required to resume the exploration, i.e. to call
the scanner. This is done once the hook routine has returned.

The scanner provides a set of default callback for the nodes. This
way, the user only have to provide call-backs for the leaves.

The scan is started with a call to C<scan_node>. The first parameter
of scan_node is a ref that is passed untouched to all call-back. This
ref may be used to store whatever result you want.

=head1 CONSTRUCTOR

=head2 new

One way or another, the ObjTreeScanner object must be able to find all
callback for all the items of the tree. All the possible call-back and
hooks are listed below:

=over

=item leaf callback:

C<leaf_cb> is a catch-all generic callback. All other are specialized
call-back : C<enum_value_cb>, C<integer_value_cb>, C<number_value_cb>,
C<boolean_value_cb>, C<string_value_cb>, C<uniline_value_cb>,
C<reference_value_cb>, C<file_value_cb>, C<dir_value_cb>

=item node callback:

C<node_content_cb> , C<node_dispatch_cb>

=item node hooks:

C<node_content_hook>

=item element callback:

All these call-backs are called on the elements of a node:
C<list_element_cb>, C<check_list_element_cb>, C<hash_element_cb>,
C<node_element_cb>, C<node_content_cb>.

=item element hooks:

C<list_element_hook>, C<hash_element_hook>.

=back

The user may specify callbacks them by passing a sub ref to the
constructor:

   $scan = Config::Model::ObjTreeScanner-> new
  (
   list_element_cb => sub { ... },
   ...
  )

C<leaf_cb> callback is mandatory. Other callbacks are provided by default.

Optional parameter:

=over

=item fallback

Deprecated with version 2.159. This parameter is now ignored and
default callbacks are always provided.

=item auto_vivify

Whether to create configuration objects while scanning (default is 1).

=item check

C<yes>, C<no> or C<skip>.

=back

=head1 Callback prototypes

=head2 Leaf callback

C<leaf_cb> is called for each leaf of the tree. The leaf callback is
called with the following parameters:

 ($scanner, $data_ref,$node,$element_name,$index, $leaf_object)

where:

=over

=item *

C<$scanner> is the scanner object.

=item *

C<$data_ref> is a reference that is first passed to the first call of
the scanner. Then C<$data_ref> is relayed through the various
call-backs

=item *

C<$node> is the node that contain the leaf.

=item *

C<$element_name> is the element (or attribute) that contain the leaf.

=item *

C<$index> is the index (or hash key) used to get the leaf. This may
be undefined if the element type is scalar.

=item *

C<$leaf_object> is a L<Config::Model::Value> object.

=back

=head2 List element callback

C<list_element_cb> is called on all list element of a node, i.e. call
on the list object itself and not in the elements contained in the
list.

 ($scanner, $data_ref,$node,$element_name,@indexes)

C<@indexes> is a list containing all the indexes of the list.

Example:

  sub my_list_element_cb {
     my ($scanner, $data_ref,$node,$element_name,@idx) = @_ ;

     # custom code using $data_ref

     # resume exploration (if needed)
     foreach my $i (@idx){
         $scanner->scan_list($data_ref,$node,$element_name,$i);
     }

     # note: scan_list and scan_hash are equivalent
  }

=head2 List element hook

C<list_element_hook>: Works like the list element callback. Except that the calls to
C<scan_list> are not required. This is done once the hook returns.

=head2 Check list element callback

C<check_list_element_cb>: Like C<list_element_cb>, but called on a
check_list element.

 ($scanner, $data_ref,$node,$element_name, index, check_list_obj)

C<index> is always undef as a check_list cannot be contained in a hash or list (yet)

=head2 Hash element callback

C<hash_element_cb>: Like C<list_element_cb>, but called on a
hash element.

 ($scanner, $data_ref,$node,$element_name,@keys)

C<@keys> is an list containing all the keys of the hash.

Example:

  sub my_hash_element_cb {
     my ($scanner, $data_ref,$node,$element_name,@keys) = @_ ;

     # custom code using $data_ref

     # resume exploration
     foreach my $k (@keys) {
         $scanner->scan_hash($data_ref,$node,$element_name,$key);
     }
  }

=head2 Hash element hook

C<hash_element_hook>: Works like the hash element callback. Except that the calls to
C<scan_hash> are not required. This is done once the hook returns.

=head2 Node content callback

C<node_content_cb>: This call-back is called foreach node (including
root node).

 ($scanner, $data_ref,$node,@element_list)

C<@element_list> contains all the element names of the node.

Example:

  sub my_content_cb {
     my ($scanner, $data_ref,$node,@elements) = @_ ;

     # custom code using $data_ref

     # resume exploration
     foreach my $elt (@elements) {
         $scanner->scan_element($data_ref, $node,$elt);
     }
  }

=head2 Node content hook

C<node_content_hook>: This hook is called foreach node (including
root node). Works like the node content call-back. Except that the calls to
C<scan_element> are not required. This is done once the hook returns.

=head2 Dispatch node callback

C<node_dispatch_cb>: Any callback specified in the hash is called for
each instance of the specified configuration class.
(this may include the  root node).

For instance, if you have:

  node_dispach_cb => {
    ClassA => \&my_class_a_dispatch_cb,
    ClassB => \&my_class_b_dispatch_cb,
  }

C<&my_class_a_dispatch_cb> is called for each instance of C<ClassA> and
C<&my_class_b_dispatch_cb> is called for each instance of C<ClassB>.

They is called with the following parameters:

 ($scanner, $data_ref,$node,@element_list)

C<@element_list> contains all the element names of the node.

Example:

  sub my_class_a_dispatch_cb = {
     my ($scanner, $data_ref,$node,@element) = @_ ;

     # custom code using $data_ref

     # resume exploration
     foreach my $elt (@elements) {
         $scanner->scan_element($data_ref, $node,$elt);
     }
  }

=head2 Node element callback

C<node_element_cb> is called for each node contained within a node
(i.e not with root node). This node can be held by a plain element or
a hash element or a list element:

 ($scanner, $data_ref,$node,$element_name,$key, $contained_node)

C<$key> may be undef if C<$contained_node> is not a part of a hash or
a list. C<$element_name> and C<$key> specifies the element name and
key of the the contained node you want to scan. (passed with
C<$contained_node>) Note that C<$contained_node> may be undef if
C<auto_vivify> is 0.

Example:

  sub my_node_element_cb {
    my ($scanner, $data_ref,$node,$element_name,$key, $contained_node) = @_;

    # your custom code using $data_ref

    # explore next node
    $scanner->scan_node($data_ref,$contained_node);
  }

=head1 METHODS

=head2 scan_node

Parameters: C<< ($data_r,$node) >>

Explore the node and call either C<node_dispatch_cb> (if the node class
name matches the dispatch_node hash) B<or> (e.g. xor) C<node_element_cb> passing
all element names.

C<up_cb> is called once the first callback returns.

=head2 scan_element

Parameters: C<< ($data_r,$node,$element_name) >>

Explore the element and call either C<hash_element_cb>,
C<list_element_cb>, C<node_content_cb> or a leaf call-back (the leaf
call-back called depends on the Value object properties: enum, string,
integer and so on)

=head2 scan_hash

Parameters: C<< ($data_r,$node,$element_name,$key) >>

Explore the hash member (or hash value) and call either C<node_content_cb> or
a leaf call-back.

=head2 scan_list

Parameters: C<< ($data_r,$node,$element_name,$index) >>

Just like C<scan_hash>: Explore the list member and call either
C<node_content_cb> or a leaf call-back.

=head2 get_keys

Parameters: C<< ($node, $element_name) >>

Returns an list containing the sorted keys of a hash element or returns
an list containing (0.. last_index) of an list element.

Throws an exception if element is not an list or a hash element.

=head1 AUTHOR

Dominique Dumont, (ddumont at cpan dot org)

=head1 SEE ALSO

L<Config::Model>,L<Config::Model::Node>,L<Config::Model::Instance>,
L<Config::Model::HashId>,
L<Config::Model::ListId>,
L<Config::Model::CheckList>,
L<Config::Model::Value>

=cut
