package Text::Wigwam::Dtree;

    use strict;
    use Text::Wigwam::Dtree::Const;
    use Text::Wigwam::Directives;

    our $VERSION = '0.01';

    our $drip_cache = {};

    use constant BASE => 0;
    use constant DTOP => 1;
    use constant PATH => 2;
    use constant CACH => 3;

    sub new {
        no warnings 'uninitialized';
        my ($pkg, $base, $dt_base, $dt_root, $dt_path, $dont_cache) = @_;

         # Append the directive tree root to the list (in the form of
         # a null string entry) if not specified in the path supplied.
        push( @$dt_path, '' ) unless $pkg->_has_root($dt_path);

        return bless [
            $base,
            join ( '::' =>
                split( /::/ => $base),
                split( /::/ => $dt_base),
                split( /::/ => $dt_root)
            ),
            $dt_path || '',
            $dont_cache || 0,
        ], $pkg;
    }

    sub _has_root{ !length $_ and return 1 for(@{$_[1]}) }

    sub query {
        my ($self, $tokn, $ipkg, @more) = @_;
        my ($name) = $tokn =~ /^[#][#|]?(.*$)/;

        my ($call, $prot, $nspc, $dir);

         # Inherent directive?
        if( $name =~ /[A-Z]+/ ){
            ($call, $prot, $dir, $nspc) = $self->_add_nspace(
                $self->[BASE],
                $ipkg,
                $name
            );

             # If it's been cached, then it's also been validated.
            return $self->_get_drip_info(
                $call,
                \&$call,
                $prot,
                undef,
                @more
            ) if exists $drip_cache->{$call};

             # Using bitwise-and here intentionally to circumvent
             # short-circuit behavior.
            (my $handler = defined &{"${nspc}::_$dir"}) &
            (my $proto = defined &{"${nspc}::_proto_$dir"})
              and return $self->_get_drip_info(
                $call,
                \&$call,
                $prot,
                undef,
                @more
            );

            return $self->_get_drip_info(
                '__null',
                sub {},
                undef,
                $handler | $proto ? 
                 $handler ?
                  "Directive prototype is missing ($call)"
                   :
                  "Directive handler is missing ($call)"
                  :
                 "Inherent directive is not defined ($call)",
                @more
            );
        }

         # Search the directive tree
        my @search = (); # Keep track of namespaces searched
        foreach my $pkg ( @{$self->[PATH]} ){
            ($call,$prot,$dir,$nspc) = $self->_add_nspace(
                $self->[DTOP],
                $pkg,
                $name
            );

         # If it's been cached, then it's also been validated already.
            return $self->_get_drip_info(
                $call,
                \&$call,
                $prot,
                undef,
                @more
            ) if exists $drip_cache->{$call};

         # Using bitwise-and here intentionally to circumvent
         # short-circuit behavior.
            (my $handler = defined &{"${nspc}::_$dir"}) &
            (my $proto = defined &{"${nspc}::_proto_$dir"})
              and return $self->_get_drip_info(
                $call,
                \&$call,
                $prot,
                undef,
                @more
              )
            ;

            return $self->_get_drip_info(
                '__null',
                sub {},
                undef,
                $handler ?
                 "Directive prototype is missing ($call)" :
                 "Directive handler is missing ($call)",
                @more
            ) if $handler || $proto;
            push( @search, $nspc );
        }
        return $self->_get_drip_info(
            '__null', # Prevent drip cache pollution
            sub {},
            undef,
            length($name) ? 
                "'#$dir' was not found in directive path ".
                join( ', ' => @search )
            :
                "Cannot process a null string directive.",
            @more,
        );
    }

    sub _get_drip_info {
     # returns fq_handler, handler_coderef, prototype, localvars, error
                no strict "refs";
        my ($self, $call, $subr, $prot, $err, $dont_cache) = @_;
        return ( $call, $subr, [], '', $err ) if $err;

        $dont_cache ||= $self->[CACH];

        return @{$drip_cache->{$call}}
          if !$dont_cache && exists $drip_cache->{$call};

        my $Cons = Text::Wigwam::Dtree::Const->new;
        my ($args, $vars) = $prot->($Cons);

        return ( $call, $subr, [], '', $Cons->err ) if $Cons->err;

         # Verify that argument masks are at least numeric
        $args ||= [];
        return (
            '__null',
            sub {},
            [],
            '',
            "Prototype did not return an array reference '$prot'."
        ) unless ref $args eq 'ARRAY';

        /^\d+/ or return (
            '__null',
            sub {},
            [],
            '',
            "Bad argument type declared in prototype '$prot'."
        ) for (@$args);

        $vars ||= '';
        $vars and ref($vars) ne 'ARRAY' and return (
            '__null',
            sub {},
            [],
            '',
            "Invalid local vars parameter in prototype '$prot'."
        );

        return @{ $drip_cache->{$call} = [$call,\&$call,$args,$vars] }
          unless $dont_cache;
        return ( $call, \&$call, $args, $vars );
    }

    sub _add_nspace {
        no warnings 'uninitialized';
        my @arr = (
            split( /::/ => $_[1] ),
            split( /::/ => $_[2] ),
            split( /::/ => $_[3] )
        );
        my ($name, $call) = ( pop @arr, join( '::', @arr ) );
        return(
            "${call}::_$name",
            "${call}::_proto_$name",
            $name,
            $call,
        );
    }

1;

__END__

This directive tree module searches for directives within the directive
tree. Upon locating a directive, it returns pertinent information about
the directive. Upon failure, it returns null values along with an error
message. This module also employs a low-level cache which can be enabled
or disabled at init time, or on the fly.

An example of constructor usage:
(only the first argument is required, the rest are optional)

 my $Dtree = Text::Wigwam::Dtree->new (
    'Text::Wigwam',       # Package
    'Directives',         # Directive tree base
    ''                    # Directive tree root
    [                     # Directive tree path
         '',
         'sublevel1',
         'sublevel2'
      ],
    0,                    # 1 = Cache off
 );

The Dtree module provides a single 'query' method. Like the constructor,
only the first argument is required.

 $Dtree->query (
      '#foobar', # No brackets allowed.
      'Engine::Foomatic::Inherent_directives',
      0,         # 1 = Cache off
 );

