123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657 |
- package Automake::Condition;
- use 5.006;
- use strict;
- use Carp;
- require Exporter;
- use vars '@ISA', '@EXPORT_OK';
- @ISA = qw/Exporter/;
- @EXPORT_OK = qw/TRUE FALSE reduce_and reduce_or/;
- use vars '%_condition_singletons';
- sub new ($;@)
- {
- my ($class, @conds) = @_;
- my $self = {
- hash => {},
- };
- bless $self, $class;
- for my $cond (@conds)
- {
-
-
- confess "'$cond' is a reference, expected a string" if ref $cond;
-
- confess "'$cond' does not look like a condition" if $cond =~ /::/;
- }
-
- @conds = map { split (' ', $_) } @conds;
- for my $cond (@conds)
- {
- next if $cond eq 'TRUE';
-
- if (($cond eq 'FALSE' && $#conds > 0)
- || ($cond =~ /^(.*)_TRUE$/ && exists $self->{'hash'}{"${1}_FALSE"})
- || ($cond =~ /^(.*)_FALSE$/ && exists $self->{'hash'}{"${1}_TRUE"}))
- {
- return &FALSE;
- }
- $self->{'hash'}{$cond} = 1;
- }
- my $key = $self->string;
- if (exists $_condition_singletons{$key})
- {
- return $_condition_singletons{$key};
- }
- $_condition_singletons{$key} = $self;
- return $self;
- }
- sub merge ($@)
- {
- my ($self, @otherconds) = @_;
- new Automake::Condition (map { $_->conds } ($self, @otherconds));
- }
- sub merge_conds ($@)
- {
- my ($self, @conds) = @_;
- new Automake::Condition $self->conds, @conds;
- }
- sub strip ($$)
- {
- my ($self, $minus) = @_;
- my @res = grep { not $minus->_has ($_) } $self->conds;
- return new Automake::Condition @res;
- }
- sub conds ($ )
- {
- my ($self) = @_;
- my @conds = keys %{$self->{'hash'}};
- return ("TRUE") unless @conds;
- return sort @conds;
- }
- sub _has ($$)
- {
- my ($self, $cond) = @_;
- return exists $self->{'hash'}{$cond};
- }
- sub false ($ )
- {
- my ($self) = @_;
- return $self->_has ('FALSE');
- }
- sub true ($ )
- {
- my ($self) = @_;
- return 0 == keys %{$self->{'hash'}};
- }
- sub string ($ )
- {
- my ($self) = @_;
- return $self->{'string'} if defined $self->{'string'};
- my $res = '';
- if ($self->false)
- {
- $res = 'FALSE';
- }
- else
- {
- $res = join (' ', $self->conds);
- }
- $self->{'string'} = $res;
- return $res;
- }
- sub _to_human ($ )
- {
- my ($s) = @_;
- if ($s =~ /^(.*)_(TRUE|FALSE)$/)
- {
- return (($2 eq 'FALSE') ? '!' : '') . $1;
- }
- else
- {
- return $s;
- }
- }
- sub human ($ )
- {
- my ($self) = @_;
- return $self->{'human'} if defined $self->{'human'};
- my $res = '';
- if ($self->false)
- {
- $res = 'FALSE';
- }
- else
- {
- $res = join (' and ', map { _to_human $_ } $self->conds);
- }
- $self->{'human'} = $res;
- return $res;
- }
- sub subst_string ($ )
- {
- my ($self) = @_;
- return $self->{'subst_string'} if defined $self->{'subst_string'};
- my $res = '';
- if ($self->false)
- {
- $res = '#';
- }
- elsif (! $self->true)
- {
- $res = '@' . join ('@@', sort $self->conds) . '@';
- }
- $self->{'subst_string'} = $res;
- return $res;
- }
- sub true_when ($$)
- {
- my ($self, $when) = @_;
-
-
- return 0 if $self->false || $when->false;
-
- return 1 if $self->true;
-
-
- foreach my $cond ($self->conds)
- {
- return 0 unless $when->_has ($cond);
- }
- return 1;
- }
- sub redundant_wrt ($@)
- {
- my ($self, @conds) = @_;
- foreach my $cond (@conds)
- {
- return 1 if $self->true_when ($cond);
- }
- return $self->false;
- }
- sub implies_any ($@)
- {
- my ($self, @conds) = @_;
- foreach my $cond (@conds)
- {
- return 1 if $cond->true_when ($self);
- }
- return 0;
- }
- sub not ($ )
- {
- my ($self) = @_;
- return @{$self->{'not'}} if defined $self->{'not'};
- my @res =
- map { new Automake::Condition &conditional_negate ($_) } $self->conds;
- $self->{'not'} = [@res];
- return @res;
- }
- sub multiply ($@)
- {
- my ($self, @set) = @_;
- my %res = ();
- for my $cond (@set)
- {
- my $ans = $self->merge ($cond);
- $res{$ans} = $ans;
- }
-
- delete $res{FALSE};
-
-
- return ($self, ())
- if exists $res{$self};
- return (values %res);
- }
- use constant TRUE => new Automake::Condition "TRUE";
- use constant FALSE => new Automake::Condition "FALSE";
- sub reduce_and (@)
- {
- my (@conds) = @_;
- my @ret = ();
- my $cond;
- while (@conds > 0)
- {
- $cond = shift @conds;
-
- return FALSE
- if $cond == FALSE;
- if (! $cond->redundant_wrt (@ret, @conds))
- {
- push (@ret, $cond);
- }
- }
- return TRUE if @ret == 0;
- return @ret;
- }
- sub reduce_or (@)
- {
- my (@conds) = @_;
- my @ret = ();
- my $cond;
- while (@conds > 0)
- {
- $cond = shift @conds;
- next
- if $cond == FALSE;
- return TRUE
- if $cond == TRUE;
- push (@ret, $cond)
- unless $cond->implies_any (@ret, @conds);
- }
- return FALSE if @ret == 0;
- return @ret;
- }
- sub conditional_negate ($)
- {
- my ($cond) = @_;
- $cond =~ s/TRUE$/TRUEO/;
- $cond =~ s/FALSE$/TRUE/;
- $cond =~ s/TRUEO$/FALSE/;
- return $cond;
- }
- 1;
|