File Coverage

blib/lib/Perl/Configure/Questions.pm

Criterion	Covered	Total	%
statement	49	57	85.9
branch	2	2	100.0
condition			n/a
subroutine	11	13	84.6
pod	1	10	10.0
total	63	82	76.8

package Perl::Configure::Questions;
use strict;
use warnings;
use YAML qw(Load);

our @QA = yaml_read();

###########################################
sub new {
###########################################
    my($class) = @_;

    my $self = {
    };

    bless $self, $class;
}

###########################################
sub add {
###########################################
    my($self, $token, $question,
       $sample_answer, $override) = @_;

    push @QA, [$token, $question, $sample_answer, $override];
}

###########################################
sub remove {
###########################################
    my($self, $token) = @_;

    @QA = grep { $_->[0] ne $token } @QA;
}

###########################################
sub yaml_read {
###########################################
    my($self) = @_;

    my $text = join '', ;
    my @data = Load($text);

    return @data;
}

###########################################
sub by_key {
###########################################
    my($self) = @_;

    my %by_key = ();

    for (@QA) {
        $by_key{$_->[0]} = [ $_->[1], $_->[2], $_->[3] ];
    }

    return \%by_key;
}

###########################################
sub by_pattern {
###########################################
    my($self) = @_;

    my @patterns = $self->patterns();
    my %by_match = ();

    for (@QA) {
        $by_match{shift @patterns} = [ $_->[0], $_->[2], $_->[3] ];
    }

    return \%by_match;
}

###########################################
sub by_match {
###########################################
    my($self) = @_;

    my %by_match = ();

    for (@QA) {
        $by_match{$_->[1]} = [ $_->[0], $_->[2] ];
    }

    return \%by_match;
}

###########################################
sub questions {
###########################################
    my($self) = @_;

    return map { $_->[1] } @QA;
}

###########################################
sub patterns {
###########################################
    my($self) = @_;

    my @patterns = ();

    for my $question (questions()) {

        my $pattern = "";
        my $rest    = $question;

        { if($rest =~ /\G(.*?)ANY\{.*?}(.*)/g) {
              $pattern .= quotemeta($1);
              $pattern .= ".*?";
              $rest     = $2;
              redo;
          } else {
              $pattern .= quotemeta($rest);
          }
        }

        push @patterns, $pattern;
    }

    return @patterns;
}

###########################################
sub tokens {
###########################################
    my($self) = @_;

    return map { $_->[0] } @QA;
}

1;

=head1 NAME

Perl::Configure::Questions - Questions asked by perl's Configure

=head1 SYNOPSIS

  use Perl::Configure::Questions;

  my $q = Perl::Configure::Questions->new();

      # Add a new (customized) token/question
  $q->add($token, $question, $sample_answer, $override)

      # These are used by Perl::Configure internally
  my @questions = $q->questions();
  my @patterns  = $q->patterns();
  my @tokens    = $q->tokens();
  my $by_key    = $q->by_key();

=head1 DESCRIPTION

C returns a list of questions asked by perl's Configure.
C just runs a quotemeta() on the strings returned by
@questions. This module is used internally by Perl::Configure.

=head2 Question Format

The questions recognized by C are stored in YAML format
in the __DATA__ section of C:

    ...
    ---
    - vendor-specific-prefix
    - Installation prefix to use for vendor-supplied add-ons?
    - '/foobar'
    ---
    ...

The first line in each tuple (separated by --- according to YAML rules)
holds the token, C in the example above. The second
line shows the question regular expression and the third line a
'sample answer', which is just used for documentation purposes.

=head2 Overriding Configure's defaults by default

If there is an optional forth line specifying an override answer,
Perl::Configure will use this answer on a match that does not have
an answer defined by the user. For example, when a part of the installation
path is missing, perl's Configure will ask "Use that name anyway?" and
provide "n" as a default. This, of course, is unfortunate, since accepting
the default will cause Configure to pop the question again and have
Perl::Configure enter an endless loop.

For this reason, "dir-check" has a fourth parameter defined that overrides
Configure's default of "n" with "y":

    - dir-check
    - Use that name anyway?
    - n
    - y

Same holds true for the question of reusing an existing config.sh file,
which gets overridden to "n" to start from a clean slate every time.

=head2 Fuzzy matching

Note that regex meta characters in the question line are B escaped.
Instead, if a part of the question should match I text, use the
ANY{...} clause:

    ...
    ---
    - compiler-flags-special
    - Any special flags to pass to ANY{cc -c} to compile shared library modules?
    - '-fpic'
    ---
    ...

This will cause the question matcher to accept any text instead of
C, which comes in handy if Configure dynamically replaces these
parts based on previous selections.

=head2 Remove questions

To debug problems with automatically provided answers that cause
endless loops during the configuration process, it sometimes helps
to remove a question from the Perl::Configure pool:

  my $q = Perl::Configure::Questions->new();
  $q->remove('dynamic-extensions');

  my $conf = Perl::Configure->new( questions => $q );

In this example, Perl::Configure won't recognize the question on dynamic
extentions anymore and therefore block the Configure process at this question,
allowing the operator to examine the question and the proposed answer
thoroughly.

=head1 AUTHOR

Mike Schilli, [e-mail], 2006

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006 by Mike Schilli

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.5 or,
at your option, any later version of Perl 5 you may have available.

=cut

__DATA__