File Coverage

blib/lib/Config/Model/Itself/BackendDetector.pm

Criterion	Covered	Total	%
statement	56	56	100.0
branch	8	10	80.0
condition	10	13	76.9
subroutine	10	10	100.0
pod	0	2	0.0
total	84	91	92.3

#
# This file is part of Config-Model-Itself
#
# This software is Copyright (c) 2007-2017 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Itself::BackendDetector ;
$Config::Model::Itself::BackendDetector::VERSION = '2.013';
# since this package is mostly targeted for dev environments
# let the detector detect models under development
use lib 'lib';

use Pod::POM ;
use File::Find ;

use base qw/Config::Model::Value/ ;

use strict ;
use warnings ;

sub setup_enum_choice {
    my $self = shift ;

    # using a hash to make sure that a backend is not listed twice. This may
    # happen in development environment where a backend in found in /usr/lib
    # and in ./lib (or ./blib)
    my %choices = map { ($_ => 1);} ref $_[0] ? @{$_[0]} : @_ ;

    # find available backends in all @INC directories
    my $wanted = sub {
        my $n = $File::Find::name ;
        if (-f $_ and $n =~ s/\.pm$// and $n !~ /Any$/) {
	    $n =~ s!.*Backend/!! ;
	    $n =~ s!/!::!g ;
	    $choices{$n} = 1 ;
        }
    } ;

    foreach my $inc (@INC) {
        my $path = "$inc/Config/Model/Backend" ;
        find ($wanted, $path ) if -d $path;
    }

    $self->SUPER::setup_enum_choice(sort keys %choices) ;
}

sub set_help {
    my ($self,$args) = @_ ;

    my $help = delete $args->{help} || {} ;

    my $path = $INC{"Config/Model.pm"} ;
    $path =~ s!\.pm!/Backend! ;

    my $parser = Pod::POM->new();

    my $wanted = sub {
        my $n = $File::Find::name ;

        return unless (-f $n and $n !~ /Any\.pm$/) ;
        my $file = $n ;
        $n =~ s/\.pm$//;
        $n =~ s!/!::!g ;
        my $perl_name = $n ;
        $n =~ s!.*Backend::!! ;
        $perl_name =~ s!.*Config!Config! ;

        my $pom = $parser->parse_file($file)|| die $parser->error();

        foreach my $head1 ($pom->head1()) {
            if ($head1->title() eq 'NAME') {
                my $c = $head1->content();
                $c =~ s/.*?-\s*//;
                $c =~ s/\n//g;
                $help->{$n} = $c . " provided by L<$perl_name>";
                last;
            }
        }
    };

    find ($wanted, $path ) ;

    $self->{help} =  $help;
}

1;

# ABSTRACT:  Detect available read/write backends usable by config models

__END__