File Coverage

blib/lib/App/mkpkgconfig/PkgConfig.pm

Criterion	Covered	Total	%
statement	147	150	98.0
branch	29	44	65.9
condition	6	12	50.0
subroutine	26	26	100.0
pod	13	13	100.0
total	221	245	90.2

package App::mkpkgconfig::PkgConfig;

# ABSTRACT: output pkg-config .pc files

use v5.10.0;

use Regexp::Common 'balanced';

use Moo;

use App::mkpkgconfig::PkgConfig::Entry;
use constant Keyword => 'App::mkpkgconfig::PkgConfig::Entry::Keyword';
use constant Variable => 'App::mkpkgconfig::PkgConfig::Entry::Variable';

our $VERSION = 'v2.0.0';

use IO::File   ();
use IO::Handle ();

sub croak {
    require Carp;
    goto &Carp::croak;
}

use namespace::clean;






has _keywords => (
    is        => 'ro',
    default   => sub { {} },
    init_args => 'keywords',
);

has _variables => (
    is        => 'ro',
    default   => sub { {} },
    init_args => 'variables',
);


















sub new_from {
    my $class = shift;
    my $file = shift;

    open( my $fh, '<', $file )
      or croak ("unable to open $file\n" );

    my $pkg  = $class->new;

    while ( defined( $_ = $fh->getline) ) {

        next if /^\s*#/; # ignore comments
        next if /^\s*$/; # ignore empty lines

        chomp;
        croak( "unable to parse line: $_\n" )
          unless /^[\s]*(?[^\s:=]+)\s*(?[:=])\s*(?.*?)\s*(#.*)?$/;

        if ( $+{op} eq ':' ) {
            $pkg->add_keyword( $+{name} => $+{value} );
        }
        else {
            $pkg->add_variable( $+{name} => $+{value} );
        }
    }

    close $fh or croak;

    return $pkg;
}










sub variable {
    return $_[0]->_variables->{ $_[1] };
}









sub variables {
    return values %{ $_[0]->_variables };
}









sub keyword {
    return $_[0]->_keywords->{ $_[1] };
}










sub keywords {
    return values %{ $_[0]->_keywords };
}











sub add_variable {
    my ( $self, $name, $value ) = @_;

    croak ( "attempt to set $name to an undefined value\n" )
      unless defined $name;
    $self->_variables->{$name} = Variable->new( $name, $value );
}









sub add_variables {
    my ( $self, $variables ) = @_;

    $self->add_variable( $_, $variables->{$_} )
      for keys %{ $variables };
}










sub add_keyword {
    my ( $self, $name, $value ) = @_;

    croak ( "attempt to set $name to an undefined value\n" )
      unless defined $name;

    $self->_keywords->{$name} = Keyword->new( $name, $value );
}









sub add_keywords {
    my ( $self, $keywords ) = @_;

    $self->add_keyword( $_, $keywords->{$_} )
      for keys %{ $keywords };
}

































sub write {
    my ( $self, $file ) = ( shift, shift );

    my %options = (
                   vars => [],
                   write => 'all',
                   @_
                   );

    my $fh
      = defined $file
      ? IO::File->new( $file, 'w' )
      : IO::Handle->new_from_fd( fileno( STDOUT ), 'w' )
      or croak( "unable to create $file: $!\n" );

    if ( $options{comments} && @{ $options{comments} } ) {
        $fh->say( "# $_" ) for @{ $options{comments}};
        $fh->say();
    }

    my @entries = values %{ $self->_keywords };

    if ( $options{write} eq 'req' ) {

        if ( defined $options{vars} ) {
            push @entries, $self->_variables->{$_}
              // croak( "request for an undefined variable: $_\n" )
              for @{ $options{vars} };
        }
    }
    else {
        push @entries, values %{ $self->_variables };
    }

    my @vars_needed = $self->resolve_dependencies( @entries );

    $fh->say( "${_} = @{[ $self->_variables->{$_}->value ]}" )
      foreach $self->order_variables( @vars_needed );

    $fh->say();

    $fh->say( "${_}: @{[ $self->_keywords->{$_}->value ]}" )
      foreach order_keywords( keys %{ $self->_keywords } );

    return;
}

sub _entry_type {
    $_[0]->isa( Keyword ) ? "Keyword" : "Variable",
}











sub resolve_dependencies {
    my ( $self, @entries ) = @_;

    my %validated;
    use Hash::Ordered;

    # descend dependency tree.  use an ordered hash to keep track of
    # which variables are in the current tree, and an array of dependency
    # arrays to keep track of each variable's dependencies.  The ordered
    # hash makes it easy to generate human readable error output.

    # could have used an actual tree, but only need a fraction of the
    # functionality, and it's faster to check for duplicates in a hash
    # than to compare tree nodes.

    for my $entry ( @entries ) {
        my $track = Hash::Ordered->new;
        $track->push( $entry->name, undef );
        my @depends = ( [ $entry->depends ] );

        while ( @depends ) {

            # check dependencies for last variable
            while ( my $name = pop @{ $depends[-1] } ) {
                next if $validated{$name};

                if ( $track->exists( $name ) ) {
                    croak(
                        sprintf(
                            "%s '%s' has a circular dependency: %s\n",
                            _entry_type( $entry ),
                            $entry->name,
                            join( '->', $track->keys, $name ) ) );
                }

                my $var = $self->_variables->{$name} // croak(
                    sprintf(
                        "%s '%s' depends upon an undefined variable: %s\n",
                        _entry_type( $entry ),
                        $entry->name,
                        join( '->', $track->keys, $name, 'undef' ),
                    ) );

                $track->push( $name, undef );
                push @depends, [ $var->depends ];
            }

            my ( $name ) = $track->pop;
            $validated{$name} = undef;
            pop @depends;
        }

        delete $validated{$entry->name} if $entry->isa( Keyword );
    }

    return keys %validated;
}










sub order_variables {

    my ( $self, @needed ) = @_;

    return () unless @needed;

    @needed = do { my %uniqstr; @uniqstr{@needed} = (); keys %uniqstr; };

    my %dephash = map {
        $_ => [ ( $self->_variables->{$_} // croak( "unknown variable: $_\n" ) )->depends ] }
      @needed;

    require Algorithm::Dependency::Ordered;
    require Algorithm::Dependency::Source::HoA;

    my $ordered;

    eval {
        my $deps
          = Algorithm::Dependency::Ordered->new(
            source => Algorithm::Dependency::Source::HoA->new( \%dephash ) )
          or die( "error creating dependency object\n" );

        $ordered = $deps->schedule( @needed );

        if ( !defined $ordered ) {
            die( "error in variable dependencies: perhaps there's cycle?\n" ),;
        }
    };

    if ( length( my $err = $@ ) ) {
        require Data::Dumper;
        die( $err,
            Data::Dumper->Dump( [ \%dephash, \@needed ], [qw( deps needed )] ) );
    }

    # move variables with no dependencies to the beginning of the list
    # to make it more human friendly
    my @nodeps = sort grep { !@{ $dephash{$_} } } @$ordered;


    if ( @nodeps ) {
        my %nodeps;
        @nodeps{@nodeps} = ();
        $ordered = [ @nodeps, grep { !exists $nodeps{$_} } @$ordered ];
    }

    return @{$ordered};
}










sub order_keywords {
    my ( @keywords ) = @_;

    my %keywords;
    @keywords{ @keywords } = ();

    my @first_keys
      = grep { exists $keywords{$_} } qw( Name Description Version );
    my %last_keys;
    @last_keys{ @keywords } = ();
    delete @last_keys{@first_keys};

    return @first_keys, keys %last_keys;
}

1;

#
# This file is part of App-mkpkgconfig
#
# This software is Copyright (c) 2020 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__