File Coverage

blib/lib/Config/AutoConf/INI.pm

Criterion	Covered	Total	%
statement	112	114	98.2
branch	25	30	83.3
condition	11	20	55.0
subroutine	23	23	100.0
pod	1	1	100.0
total	172	188	91.4

use strict;
use warnings FATAL => 'all';

package Config::AutoConf::INI;
use Carp                   qw/croak/;
use Config::AutoConf 0.313 qw//;
use Config::Tiny::Ordered  qw//;
use File::Basename         qw/fileparse/;
use File::Path             qw//;
use Scalar::Util           qw/looks_like_number blessed/;
use parent                 qw/Config::AutoConf/;

# ABSTRACT: Drive Config::AutoConf with an INI file

our $VERSION = '0.005'; # VERSION

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

our $_make_path;
BEGIN {
    #
    # Old versions of File::Path does not provide make_path, but the legacy mkpath
    #
    $_make_path = File::Path->can('make_path') || File::Path->can('mkpath');
}


sub check {
    my ($self, $config_ini) = @_;

    $config_ini //= 'config_autoconf.ini';

    $self = __PACKAGE__->new() unless blessed $self;

    #
    # Internal setup
    #
    $self->{_headers_order} = 0;
    $self->{_headers_ok} = {};
    $self->{_config_ini} = $config_ini ? Config::Tiny::Ordered->read($config_ini) : {};

    #
    # Setup
    #
    $self->_process_from_config(section    => 'includes',         stub_name  => 'push_includes');
    $self->_process_from_config(section    => 'preprocess_flags', stub_name  => 'push_preprocess_flags');
    $self->_process_from_config(section    => 'compiler_flags',   stub_name  => 'push_compiler_flags');
    $self->_process_from_config(section    => 'link_flags',       stub_name  => 'push_link_flags');

    #
    # Run - the order has been choosen carefully
    #
    $self->_process_from_config(section    => 'files',         stub_name  => 'check_file',
                               force_msg   => 'file %s');
    $self->_process_from_config(section    => 'progs',         stub_name  => 'check_prog',
                                stub_names => {
                                               #
                                               # Specific implementations
                                               #
                                               yacc       => 'check_prog_yacc',
                                               awk        => 'check_prog_awk',
                                               egrep      => 'check_prog_egrep',
                                               lex        => 'check_prog_lex',
                                               sed        => 'check_prog_sed',
                                               pkg_config => 'check_prog_pkg_config',
                                               cc         => 'check_prog_cc'
                                              }
                               );
    $self->_process_from_config(section    => 'headers',        stub_name => 'check_header',       args => \&_args_check_header);
    $self->_process_from_config(section    => 'bundle',         stub_name  => '_check_bundle');
    $self->_process_from_config(section    => 'decls',          stub_name => 'check_decl',         args => \&_args_check);
    $self->_process_from_config(section    => 'funcs',          stub_name => 'check_func',         args => \&_args_check);
    $self->_process_from_config(section    => 'types',          stub_name => 'check_type',         args => \&_args_check);
    $self->_process_from_config(section    => 'sizeof_types',   stub_name => 'check_sizeof_type',  args => \&_args_check);
    $self->_process_from_config(section    => 'alignof_types',  stub_name => 'check_alignof_type', args => \&_args_check);
    $self->_process_from_config(section    => 'members',        stub_name => 'check_member',       args => \&_args_check);

    $self->_process_from_config(section    => 'outputs',        stub_name => '_write_config_h');

    map { delete $self->{$_} } qw/_config_ini _headers_ok _headers_order/;

    $self;
}

#
# Bundle check
#
sub _check_bundle {
    my ($self, $bundle) = @_;

    my @args = $self->_args_check_headers;

    if ($bundle eq 'stdc_headers') {
        $self->check_stdc_headers(@args)
    } elsif ($bundle eq 'default_headers') {
        $self->check_default_headers(@args)
    } elsif ($bundle eq 'dirent_headers') {
        $self->check_dirent_header(@args)
    }
}

#
# We want to make sure that the dirname of path exist
#
sub _write_config_h {
    my ($self, $path) = @_;

    #
    # We do not mind about suffixes, only directory name
    # Note that File::Basename says that fileparse()
    # should be used instead of dirname()
    #
    my ($filename, $dirs, $suffix) = fileparse($path);
    if ($dirs) {
        &$_make_path($dirs); # This will croak in case of failure
    }
    $self->write_config_h($path);
}

#
# Config::AutoConf does not honor all the found headers, so we generate
# ourself the prologue
#
sub _ordered_headers {
    my ($self) = @_;

    my @rc = sort { $self->{_headers_ok}->{$a} <=> $self->{_headers_ok}->{$b} } keys %{$self->{_headers_ok}};
    return @rc
}

sub _prologue {
  my ($self) = @_;

  my $prologue = join("\n", map { "#include <$_>" } $self->_ordered_headers) . "\n";

  return $prologue
}

#
# Standard option, containing prologue
#
sub _args_option {
  my ($self) = @_;

  return { prologue => $self->_prologue }
}

#
# Standard list of arguments: the original one and a hash containing the prologue
#
sub _args_check {
  my ($self, $check) = @_;

  return ($check, $self->_args_option())
}

#
# For headers, we want to remember ourself those that are ok for the prologue generation
#
sub _header_ok {
    my ($self, @headers) = @_;

    map { $self->{_headers_ok}->{$_} = $self->{_headers_order}++ unless exists $self->{_headers_ok}->{$_} } @headers
}

sub _args_check_header {
  my ($self, $header) = @_;

  my @args_check = $self->_args_check($header);
  $args_check[1]->{action_on_true} = sub { $self->_header_ok($header) };

  return @args_check
}

#
# For check_headers callback, semantic is different
#
sub _args_check_headers {
  my ($self) = @_;

  my @args_check = ($self->_args_option());
  $args_check[1]->{action_on_header_true} = sub { $self->_header_ok(@_) };

  return @args_check
}

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

    my $section    = $args{section}   || croak 'Internal error, section not set';
    my $stub_name  = $args{stub_name} || croak 'Internal error, stub_name not set';
    my $stub_names = $args{stub_names} // {};
    my $force_msg  = $args{force_msg} // '';
    my $args       = $args{args};

    my $sectionp = $self->{_config_ini}->{$section};
    $sectionp //= [];

    foreach (@{$sectionp}) {
        my $key = $_->{'key'};
        my $rhs = $_->{'value'};
        #
        # No check if rhs is not a true value
        #
        next unless $rhs;

        #
        # Get the implementation
        #
        my $stub_realname = $stub_names->{$key} || $stub_name;
        my $stub_code = $self->can($stub_realname);
        if (! $stub_code) {
          #
          # We warn because this should not happen
          #
          warn "$self cannot \"$stub_realname\"";
          next;
        }

        #
        # If there is an explicit implementation it is assumed
        # that it is handling itself any message
        #
        $force_msg = '' if $stub_realname ne $stub_name;

        #
        # Do the work
        #
        $self->msg_checking(sprintf($force_msg, $key)) if $force_msg;
        my @args = $args ? $self->$args($key) : ($key);
        my $value = $self->$stub_code(@args);
        $self->define_var($rhs, $value) unless looks_like_number($rhs);
        $self->msg_result($value ? 'yes' : 'no') if $force_msg;
    }

    $self
}


1;

__END__