File Coverage

lib/Path/FindDev/Object.pm

Criterion	Covered	Total	%
statement	50	81	61.7
branch	12	26	46.1
condition	1	3	33.3
subroutine	11	13	84.6
pod	4	4	100.0
total	78	127	61.4

use 5.008;    # utf8
use strict;
use warnings;
use utf8;

package Path::FindDev::Object;

our $VERSION = '0.5.2';

# ABSTRACT: Object oriented guts to FindDev

our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY

our $ENV_KEY_DEBUG = 'PATH_FINDDEV_DEBUG';
our $DEBUG = ( exists $ENV{$ENV_KEY_DEBUG} ? $ENV{$ENV_KEY_DEBUG} : undef );













use Class::Tiny 0.010 'set', 'uplevel_max', {
  nest_retry => sub {
    return 0;
  },
  isdev => sub {
    require Path::IsDev::Object;
    return Path::IsDev::Object->new( ( $_[0]->has_set ? ( set => $_[0]->set ) : () ) );
  },
};









## no critic (RequireArgUnpacking)







sub has_set { return exists $_[0]->{set} }















sub has_uplevel_max { return exists $_[0]->{uplevel_max} }


















my $instances   = {};
my $instance_id = 0;














sub _instance_id {
  my ($self) = @_;
  require Scalar::Util;
  my $addr = Scalar::Util::refaddr($self);
  return $instances->{$addr} if exists $instances->{$addr};
  $instances->{$addr} = sprintf '%x', $instance_id++;
  return $instances->{$addr};
}










sub BUILD {
  my ($self) = @_;
  return $self unless $DEBUG;
  $self->_debug('{');
  $self->_debug( '  set         => ' . $self->set )         if $self->has_set;
  $self->_debug( '  uplevel_max => ' . $self->uplevel_max ) if $self->uplevel_max;
  $self->_debug( '  nest_retry  => ' . $self->nest_retry );
  $self->_debug( '  isdev       => ' . $self->isdev );
  $self->_debug('}');
  return $self;
}













sub _debug {
  my ( $self, $message ) = @_;
  return unless $DEBUG;
  my $id = $self->_instance_id;
  return *STDERR->printf( qq{[Path::FindDev=%s] %s\n}, $id, $message );
}









sub _error {
  my ( $self, $message ) = @_;
  my $id = $self->_instance_id;
  my $f_message = sprintf qq{[Path::FindDev=%s] %s\n}, $id, $message;
  require Carp;
  Carp::croak($f_message);
}
















sub _step {
  my ( $self, $search_root, $dev_levels, $uplevels ) = @_;

  if ( $self->isdev->matches($search_root) ) {
    $self->_debug( 'Found dev dir' . $search_root );
    ${$dev_levels}++;
    return { type => 'found', path => $search_root } if ${$dev_levels} >= $self->nest_retry;
    $self->_debug( sprintf 'Ignoring found dev dir due to dev_levels(%s) < nest_retry(%s)', ${$dev_levels}, $self->nest_retry );
  }
  if ( $search_root->is_rootdir ) {
    $self->_debug('OS Root hit ( ->is_rootdir )');
    return { type => 'stop' };
  }
  if ( $self->has_uplevel_max and ${$uplevels} > $self->uplevel_max ) {
    $self->_debug( 'Stopping search due to uplevels(%s) >= uplevel_max(%s)', ${$uplevels}, $self->uplevel_max );
    return { type => 'stop' };
  }

  return { type => 'next' };
}









sub find_dev {
  my ( $self, $path ) = @_;
  require Path::Tiny;
  my $search_root = Path::Tiny::path($path)->absolute->realpath;
  $self->_debug( 'Finding dev for ' . $path );
  my $dev_levels = 0;
  my $uplevels   = 0 - 1;
FLOW: {
    $uplevels++;
    my $result = $self->_step( $search_root, \$dev_levels, \$uplevels );
    if ( 'next' eq $result->{type} ) {
      $self->_debug( 'Trying ../ : ' . $search_root->parent );
      $search_root = $search_root->parent;
      redo FLOW;
    }
    if ( 'stop' eq $result->{type} ) {
      return;
    }
    if ( 'found' eq $result->{type} ) {
      return $result->{path};
    }
    $self->_error( 'Unexpected end of flow control with _step response type' . $result->{type} );
  }
  return;
}
1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Path::FindDev::Object - Object oriented guts to FindDev

=head1 VERSION

version 0.5.2

=head1 SYNOPSIS

    require Path::FindDev::Object;
    my $finder = Path::FindDev::Object->new();
    my $dev = $finder->find_dev($path);

=head1 DESCRIPTION

This module implements the innards of L<< C<Path::FindDev>|Path::FindDev >>, and is
only recommended for use if the Exporter C<API> is insufficient for your needs.

=head1 METHODS

=head2 C<has_set>

Determines if the C<set> attribute exists

=head2 C<has_uplevel_max>

Determines if the C<uplevel_max> attribute is provided.

=head2 C<find_dev>

Find a parent at, or above C<$OtherPath> that resembles a C<devel> directory.

    my $path = $object->find_dev( $OtherPath );

=head1 ATTRIBUTES

=head2 C<set>

B<(optional)>

The C<Path::IsDev::HeuristicSet> subclass for your desired Heuristics.

=head2 C<uplevel_max>

If provided, limits the number of C<uplevel> iterations done.

( that is, limits the number of times it will step up the hierarchy )

=head2 C<nest_retry>

The number of C<dev> directories to C<ignore> in the hierarchy.

This is provided in the event you have a C<dev> directory within a C<dev> directory, and you wish
to resolve an outer directory instead of an inner one.

By default, this is C<0>, or "stop at the first C<dev> directory"

=head2 C<isdev>

The L<< C<Path::IsDev>|Path::IsDev >> object that checks nodes for C<dev>-ishness.

=head1 PRIVATE METHODS

=head2 C<_instance_id>

An opportunistic sequence number for help with debug messages.

Note: This is not guaranteed to be unique per instance, only guaranteed
to be constant within the life of the object.

Based on C<refaddr>, and giving out new ids when new C<refaddr>'s are seen.

    my $id = $object->_instance_id;

=head2 C<BUILD>

C<BUILD> is an implementation detail of C<Moo>/C<Moose>.

This module hooks C<BUILD> to give a self report of the object
to C<*STDERR> after C<< ->new >> when under C<$DEBUG>

=head2 C<_debug>

The debugger callback.

    export PATH_FINDDEV_DEBUG=1

to get debug info.

    $object->_debug($message);

=head2 C<_error>

The error reporting callback.

    $object->_error($message);

=head2 C<_step>

Inner code path of tree walking.

    my ($dev_levels, $uplevels ) = (0,0);

    my $result = $object->_step( path($somepath), \$dev_levels, \$uplevels );

    $result->{type} eq 'stop'   # if flow control should end
    $result->{type} eq 'next'   # if flow control should ascend to parent
    $result->{type} eq 'found'  # if flow control has found the "final" dev directory

=begin MetaPOD::JSON v1.1.0

{
    "namespace":"Path::FindDev::Object",
    "interface":"class",
    "inherits":"Class::Tiny::Object"
}


=end MetaPOD::JSON

=head1 AUTHOR

Kent Fredric <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014 by Kent Fredric <[e-mail]>.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut