File Coverage

blib/lib/Test/Smoke/BuildCFG.pm

Criterion	Covered	Total	%
statement	207	241	85.8
branch	66	92	71.7
condition	26	39	66.6
subroutine	32	34	94.1
pod	12	12	100.0
total	343	418	82.0

package Test::Smoke::BuildCFG;
use strict;

our $VERSION = '0.010';

use Cwd;
use File::Spec;
require File::Path;
use Test::Smoke::LogMixin;
use Test::Smoke::Util qw( skip_config );

my %CONFIG = (
    df_v      => 0,
    df_dfopts => '-Dusedevel',
);

=head1 NAME

Test::Smoke::BuildCFG - OO interface for handling build configurations

=head1 SYNOPSIS

    use Test::Smoke::BuildCFG;

    my $name = 'perlcurrent.cfg';
    my $bcfg = Test::Smoke::BuildCFG->new( $name );

    foreach my $config ( $bcfg->configurations ) {
        # do somthing with $config
    }

=head1 DESCRIPTION

Handle the build configurations

=head1 METHODS

=head2 Test::Smoke::BuildCFG->new( [$cfgname] )

[ Constructor | Public ]

Initialise a new object.

=cut

sub new {
    my $proto = shift;
    my $class = ref $proto ? ref $proto : $proto;

    my $config = shift;

    my %args_raw = @_ ? UNIVERSAL::isa( $_[0], 'HASH' ) ? %{ $_[0] } : @_ : ();

    my %args = map {
        ( my $key = $_ ) =~ s/^-?(.+)$/lc $1/e;
        ( $key => $args_raw{ $_ } );
    } keys %args_raw;

    my %fields = map {
        my $value = exists $args{$_} ? $args{ $_ } : $CONFIG{ "df_$_" };
        ( $_ => $value )
    } qw( v dfopts );

    my $self = bless \%fields, $class;
    $self->read_parse( $config );
}

=head2 Test::Smoke::BuildCFG->continue( $logfile[, $cfgname, %options] )

[Constructor | public]

Initialize a new object without the configurations that have already
been fully processed. If *all* configurations have been processed,
just pass the equivalent of the C method.

=cut

sub continue {
    my $proto = shift;
    my $class = ref $proto ? ref $proto : $proto;

    my $logfile = shift;

    my $self = $class->new( @_ );
    $self->{_continue} = 1;
    return $self unless $logfile && -f $logfile;

    my %seen = __get_smoked_configs( $logfile );
    my @not_seen = ();
    foreach my $config ( $self->configurations ) {
        push @not_seen, $config unless exists $seen{ "$config" } ||
                                       skip_config( $config );
    }
    return $self unless @not_seen;
    $self->{_list} = \@not_seen;
    return $self;
}

=head2 $bldcfg->verbose

[ Getter | Public]

Get verbosity.

=cut

sub verbose { $_[0]->{v} }

=head2 Test::Smoke::BuildCFG->config( $key[, $value] )

[ ClassAccessor | Public ]

C is an interface to the package lexical C<%CONFIG>,
which holds all the default values for the C arguments.

With the special key B this returns a reference
to a hash holding all the default values.

=cut

sub config {
    my $dummy = shift;

    my $key = lc shift;

    if ( $key eq 'all_defaults' ) {
        my %default = map {
            my( $pass_key ) = $_ =~ /^df_(.+)/;
            ( $pass_key => $CONFIG{ $_ } );
        } grep /^df_/ => keys %CONFIG;
        return \%default;
    }

    return undef unless exists $CONFIG{ "df_$key" };

    $CONFIG{ "df_$key" } = shift if @_;

    return $CONFIG{ "df_$key" };
}

=head2 $self->read_parse( $cfgname )

C reads the build configurations file and parses it.

=cut

sub read_parse {
    my $self = shift;

    $self->_read( @_ );
    $self->_parse;

    return $self;
}

=head2 $self->_read( $nameorref )

C<_read()> is a private method that handles the reading.

=over 4

=item B build configurations are in C<$$nameorref>

=item B build configurations are in C<@$nameorref>

=item B build configurations are read from the filehandle

=item B are taken as the filename for the build configurations

=back

=cut

sub _read {
    my $self = shift;
    my( $nameorref ) = @_;
    $nameorref = '' unless defined $nameorref;

    my $vmsg = "";
    local *BUILDCFG;
    if ( ref $nameorref eq 'SCALAR' ) {
        $self->{_buildcfg} = $$nameorref;
        $vmsg = "internal content";
    } elsif ( ref $nameorref eq 'ARRAY' ) {
        $self->{_buildcfg} = join "", @$nameorref;
        $vmsg = "internal content";
    } elsif ( ref $nameorref eq 'HASH' ) {
        $self->{_buildcfg} = undef;
        $self->{_list} = $nameorref->{_list};
        $vmsg = "continuing smoke";
    } elsif ( ref $nameorref eq 'GLOB' ) {
        *BUILDCFG = *$nameorref;
        $self->{_buildcfg} = do { local $/;  };
        $vmsg = "anonymous filehandle";
    } else {
        if ( $nameorref ) {
            if ( open BUILDCFG, "< $nameorref" ) {
                $self->{_buildcfg} = do { local $/;  };
                close BUILDCFG;
                $vmsg = $nameorref;
            } else {
                require Carp;
                Carp::carp("Cannot read buildconfigurations ($nameorref): $!");
                $self->{_buildcfg} = $self->default_buildcfg();
                $vmsg = "internal content";
            }
        } else { # Allow intentional default_buildcfg()
            $self->{_buildcfg} = $self->default_buildcfg();
            $vmsg = "internal content";
        }
    }
    $vmsg .= "[continue]" if $self->{_continue};
    $self->log_info("Reading build configurations from %s", $vmsg);
}

=head2 $self->_parse( )

C<_parse()> will split the build configurations file in sections.
Sections are ended with a line that begins with an equals-sign ('=').

There are two types of section

=over

=item B

=item B

A B contains a "target-option". This is a build option
that should be in the ccflags variable in the F file
(see also L) and starts with a (forward) slash ('/').

A B can have only one (1) target-option.

=back

=cut

sub _parse {
    my $self = shift;

    return unless defined $self->{_buildcfg}; # || $self->{_list};

    $self->{_sections} = [ ];
    my @sections = split m/^=.*\n/m, $self->{_buildcfg};
    $self->log_debug("Found %d raw-sections", scalar @sections);

    foreach my $section ( @sections ) {
        chomp $section;
        my $index = 0;
        my %opts = map { s/^\s+$//; $_ => $index++ }
            grep !/^#/ => split /\n/, $section, -1;
        # Skip empty sections
        next if (keys %opts == 0) or (exists $opts{ "" } and keys %opts == 1);

        if (  grep m|^/.+/?$| => keys %opts ) { # Policy section
            my @targets;
            my @lines = keys %opts;
            foreach my $line ( @lines ) {
                next unless $line =~ m|^/(.+?)/?$|;

                push @targets, $1;
                delete $opts{ $line };
            }
            if ( @targets > 1 ) {
                require Carp;
                Carp::carp( "Multiple policy lines in one section:\n\t",
                            join( "\n\t", @targets ),
                            "\nWill use /$targets[0]/\n" );
            }
            push @{ $self->{_sections} },
                 { policy_target => $targets[0],
                   args => [ sort {$opts{ $a } <=> $opts{ $b }} keys %opts ] };

        } else { # Buildopt section
            push @{ $self->{_sections} },
                 [ sort {$opts{ $a } <=> $opts{ $b }} keys %opts ];
        }
    }
    # Make sure we have at least *one* section
    push @{ $self->{_sections} }, [ "" ] unless @{ $self->{_sections} };

    $self->log_debug("Left with %d parsed sections", scalar @{$self->{_sections}});
    $self->_serialize;
    $self->log_debug("Found %d (unfiltered) configurations", scalar @{$self->{_list}});
}

=head2 $self->_serialize( )

C<_serialize()> creates a list of B
objects from the parsed sections.

=cut

sub _serialize {
    my $self = shift;

    my $list = [ ];
    __build_list( $list, $self->{dfopts}, [ ], @{ $self->{_sections} } );

    $self->{_list} = $list;
}

=head2 __build_list( $list, $previous_args, $policy_subst, $this_cfg, @cfgs )

Recursive sub, mainly taken from the old C in F

=cut

sub __build_list {
    my( $list, $previous_args, $policy_subst, $this_cfg, @cfgs ) = @_;

    my $policy_target;
    if ( ref $this_cfg eq "HASH" ) {
        $policy_target = $this_cfg->{policy_target};
        $this_cfg      = $this_cfg->{args};
    }

    foreach my $conf ( @$this_cfg ) {
        my $config_args = $previous_args;
        $config_args .= " $conf" if length $conf;

        my @substitutions = @$policy_subst;
        push @substitutions, [ $policy_target, $conf ]
            if defined $policy_target;

        if ( @cfgs ) {
            __build_list( $list, $config_args, \@substitutions, @cfgs );
            next;
        }

        push @$list, Test::Smoke::BuildCFG::Config->new(
            $config_args, @substitutions
        );
    }
}

=head2 $buildcfg->configurations( )

Returns the list of configurations (Test::Smoke::BuildCFG::Config objects)

=cut

sub configurations {
    my $self = shift;

    @{ $self->{_list} };
}

=head2 $buildcfg->policy_targets( )

Returns a list of policytargets from the policy substitution sections

=cut

sub policy_targets {
    my $self = shift;

    return unless UNIVERSAL::isa( $self->{_sections}, "ARRAY" );

    my @targets;
    for my $section ( @{ $self->{_sections} } ) {
        next unless UNIVERSAL::isa( $section, "HASH" ) &&
                    $section->{policy_target};
        push @targets, $section->{policy_target};
    }

    return @targets;
}

=head2 as_string

Return the parsed configuration as a string.

=cut

sub as_string {
    my $self = shift;
    my @sections;
    for my $section ( @{ $self->{_sections} } ) {
        if ( UNIVERSAL::isa( $section, 'ARRAY' ) ) {
            push @sections, $section;
        } elsif ( UNIVERSAL::isa( $section, 'HASH' ) ) {
            push @sections, [
                "/$section->{policy_target}/",
                @{ $section->{args} },
            ];
        }
    }
    return join "=\n", map join( "\n", @$_, "" ) => @sections;
}

=head2 source

returns the text-source of this instance.

=cut

sub source {
    my $self = shift;

    return $self->{_buildcfg};
}

=head2 sections

returns an ARRAYREF of the sections in this instance.

=cut

sub sections {
    my $self = shift;

    return $self->{_sections};
}

=head2 __get_smoked_configs( $logfile )

Parse the logfile and return a hash(ref) of already processed
configurations.

=cut

sub __get_smoked_configs {
    my( $logfile ) = @_;

    my %conf_done = ( );
    local *LOG;
    if ( open LOG, "< $logfile" ) {
        my $conf;
        # A Configuration is done when we detect a new Configuration:
        # or the phrase "Finished smoking $patch"
        while (  ) {
            s/^Configuration:\s*// || /^Finished smoking/ or next;
            $conf and $conf_done{ $conf }++;
            chomp; $conf = $_;
        }
        close LOG;
    }
    return wantarray ? %conf_done : \%conf_done;
}

=head2 Test::Smoke::BuildCFG->default_buildcfg()

This is a constant that returns a textversion of the default
configuration.

=cut

sub default_buildcfg() {

    return <<__EOCONFIG__;
# Test::Smoke::BuildCFG->default_buildcfg
# Check the documentation for more information
== Build all configurations with and without ithreads

-Duseithreads
== Build with and without 64bitall

-Duse64bitall
== All configurations with and without -DDEBUGGING
/-DDEBUGGING/

-DDEBUGGING
__EOCONFIG__
}

=head2 new_configuration( $config )

A wrapper around C<< Test::Smoke::BuildCFG::Config->new() >> so the
object is accessible from outside this package.

=cut

sub new_configuration {
    return Test::Smoke::BuildCFG::Config->new( @_ );
}

1;

package Test::Smoke::BuildCFG::Config;

use overload
    '""'     => sub { $_[0]->[0] || "" },
    fallback => 1;

use Text::ParseWords qw( quotewords );

=head1 PACKAGE

Test::Smoke::BuildCFG::Config - OO interface for a build confiuration

=head1 SYNOPSIS

    my $bcfg = Test::Smoke::BuildCFG::Config->new( $args, $policy );

or

    my $bcfg = Test::Smoke::BuildCFG::Config->new;
    $bcfg->args( $args );
    $bcfg->policy( [ -DDEBUGGING => '-DDEBUGGING' ],
                   [ -DPERL_COPY_ON_WRITE => '' ] );

    if ( $bcfg->has_arg( '-Duseithreads' ) ) {
        # do stuff for -Duseithreads
    }

=head1 DESCRIPTION

This is a simple object that holds both the build arguments and the
policy substitutions. The build arguments are stored as a string and
the policy subtitutions are stored as a list of lists. Each substitution is
represented as a list with the two elements: the target and its substitute.

=head1 METHODS

=head2 Test::Smoke::BuildCFG::Config->new( [ $args[, \@policy_substs ]] )

Create the new object as an anonymous list.

=cut

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;

    my $self = bless [ undef, [ ], { } ], $class;

    @_ >= 1 and $self->args( shift );
    @_ >  0 and $self->policy( @_ );

    $self;
}

=head2 $buildcfg->args( [$args] )

Accessor for the build arguments field.

=cut

sub args {
    my $self = shift;

    if ( defined $_[0] ) {
        $self->[0] = shift;
        $self->_split_args;
    }

    $self->[0];
}

=head2 $buildcfg->policy( [@substitutes] )

Accessor for the policy substitutions.

=cut

sub policy {
    my $self = shift;

    if ( @_ ) {
        my @substitutions = @_ == 1 &&  ref $_[0][0] eq 'ARRAY'
            ? @{ $_[0] } : @_;
        $self->[1] = \@substitutions;
    }

    @{ $self->[1] };
}

=head2 $self->_split_args( )

Create a hash with all the build arguments as keys.

=cut

sub _split_args {
    my $self = shift;

    my $i = 0;
    $self->[2] = {
        map { ( $_ => $i++ ) } quotewords( '\s+', 1, $self->[0] )
    };
    $self->[0] = join( " ", sort {
        $self->[2]{ $a } <=> $self->[2]{ $b }
    } keys %{ $self->[2] } ) || "";
}

=head2 $buildcfg->has_arg( $arg[,...] )

Check the build arguments hash for C<$arg>. If you specify more then one
the results will be logically ANDed!

=cut

sub has_arg {
    my $self = shift;

    my $ok = 1;
    $ok &&= exists $self->[2]{ $_ } foreach @_;
    return $ok;
}

=head2 $buildcfg->any_arg( $arg[,...] )

Check the build arguments hash for C<$arg>. If you specify more then one
the results will be logically ORed!

=cut

sub any_arg {
    my $self = shift;

    my $ok = 0;
    $ok ||= exists $self->[2]{ $_ } foreach @_;
    return $ok;
}

=head2 $buildcfg->args_eq( $args )

C takes a string of config arguments and returns true if
C<$self> has exactly the same args as the C<$args> has.

There is the small matter of default_args (dfopts) kept as a Class
variable in L!

=cut

sub args_eq {
    my $self = shift;
    my $args = shift;

    my $default_args = join "|", sort {
        length($b) <=> length($a)
    } quotewords( '\s+', 1, Test::Smoke::BuildCFG->config( 'dfopts' ) );

    my %copy = map { ( $_ => undef ) }
        grep !/$default_args/ => keys %{ $self->[2] };
    my @s_args = grep !/$default_args/ => quotewords( '\s+', 1, $args );
    my @left;
    while ( my $option = pop @s_args ) {
        if ( exists $copy{ $option } ) {
            delete $copy{ $option };
        } else {
            push @left, $option;
        }
    }
    return (@left || keys %copy) ? 0 : 1;
}

=head2 $config->rm_arg( $arg[,..] )

Simply remove the argument(s) from the list and recreate the arguments
line.

=cut

sub rm_arg {
    my $self = shift;

    foreach my $arg ( @_ ) {
        exists $self->[2]{ $arg } and delete $self->[2]{ $arg };
    }
    $self->[0] = join( " ", sort {
        $self->[2]{ $a } <=> $self->[2]{ $b }
    } keys %{ $self->[2] } ) || "";
}

=head2 $config->vms

Redo the the commandline switches in a VMSish way.

=cut

sub vms {
    my $self = shift;

    return join( " ", map {
        tr/"'//d;
        s/^-//;
        qq/-"$_"/;
    } sort {
        $self->[2]{ $a } <=> $self->[2]{ $b }
    } keys %{ $self->[2] } ) || "";
}

1;

=head1 SEE ALSO

L, L

=head1 COPYRIGHT

(c) 2002-2003, All rights reserved.

  * Abe Timmerman

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

See:

=over 4

=item * http://www.perl.com/perl/misc/Artistic.html

=item * http://www.gnu.org/copyleft/gpl.html

=back

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

=cut