=head1 NAME

CFX5::Attr - architecture/attribute handling

=head1 SYNOPSIS

  use CFX5::Attr;

=head1 DESCRIPTION

This module handles the standard CFX-5 architectural attributes.  It
is provided as a standalone module, which can be used by any other
modules wishing to use these pieces of information, since the
information is slightly complex.

=cut

package CFX5::Attr;
use strict;
use Carp;

use Config qw(%Config);
use CFX5::Output qw(:all);

=head2 ATTRIBUTE LISTS

This module has an inbuilt idea of the available attributes.  Unknown
attributes are signalled with an error.  New attributes can be added
via the I<class-wide> C<AddAttrGroup> call, and will automatically be
recognised and used by all objects of this type.  All the methods in
this section are class methods, but may be called on individual
objects of the class as well.


Data structure:

 _attrgroups    : group number for each attribute
 _groupattrs    : list of attributes for each group
 _groupstates   : list of current states for each group
 _groupdefaults : list of default states for each group

=cut


=head3 AddAttrGroup

  $aa->AddAttrGroup('32bit','64bit');

This is a class method which adds a new attribute group, defined as
a list of attributes, in which one attribute is selected.

The first argument in the list is the default attribute.

If only one argument <attr> is specified, its inverse 'noI<attr>'
will automatically be prepended (and be the default).

For example: $aa->AddAttrGroup('debug');
is equivalent to $aa->AddAttrGroup('nodebug','debug');

=cut

sub AddAttrGroup
{
  my $this=shift;
  my @attrs = @_;

  # For single arguments, add 'no<attr>'
  unshift @attrs, 'no'.$attrs[0] if (scalar(@attrs) == 1);

  my $rgrps   = $this->{_attrgroups};
  my $rattrs  = $this->{_groupattrs};   
  my $rstates = $this->{_groupstates}; 
  my $rdefs   = $this->{_groupdefaults};

  # Check if attributes are already defined an an existing group
  # If one attribute already exists, all attributes must already exist
  # and be consistent (i.e. 1st is default)
  my $nexist = 0;
  for my $attr (@attrs)
  {
    $nexist++ if (exists $rgrps->{$attr});
  }

  if ($nexist)
  {
    unless ($nexist == scalar(@attrs))
    {
      croak(sprintf "Inconsistent re-specification of attribute group: %s -> Not all attributes pre-exist.\n", join('|',@attrs));
    }

    my $group = $rgrps->{$attrs[0]};
    unless ($attrs[0] eq $rdefs->[$group])
    {
      croak(sprintf "Inconsistent re-specification of attribute group: %s -> Default attribute differs.\n", join('|',@attrs));
    }
  }

  my $i = scalar(@{ $rattrs });
  for my $attr (@attrs)
  {
    $rgrps->{$attr} = $i;
  }

  push @{ $rattrs }, [ @attrs ];
  push @{ $rstates }, 0;
  push @{ $rdefs }, 0;
}

=head3 AttrList

  @allattrs=$aa->AttrList();
  @allattrs=CFX5::Attr->AttrList();

This is a class method which returns the list of known attributes, in
order of definition.

=cut

sub AttrList
{
  my $this=shift;
  my @attrs;

  my $rattrs = $this->{_groupattrs};   

  for my $group (@{$rattrs})
  {
    for my $attr (@{ $group })
    {
      push @attrs, $attr;
    }
  }

  # and remove the empty items
  return grep { defined $_ } @attrs;
}

=head3 IsValidAttr

This is a class method which returns TRUE if the given attribute is
valid, or FALSE if it is not known.  Additionally, the TRUE value will
it will be 'std' if this is a known attribute.

=cut

sub IsValidAttr
{
  my $this=shift;
  my $attr=shift;

  my $rgrps = $this->{_attrgroups};

  if (exists $rgrps->{$attr}) {
    return 'std';
  } else {
    return '';
  }
}

=head2 INITIALISATION

=head3 new

  my $arch=new CFX5::Attr;

Returns a new blank object, with all attributes set to their default
values.

  my $arch=new CFX5::Attr('double-debug');

Creates a new object, and passes the attribute list to
C<specify_attr_list> to set the initial state of the object.

=cut

sub new {
  my $this=shift;
  my $class=ref($this) || $this;
  my $self = {};

  $self->{_attrgroups} = {};
  $self->{_groupattrs} = [];
  $self->{_groupstates} = [];
  $self->{_groupdefaults} = [];

  bless $self, $class;

  $self->set_std_attrs();

  if (@_) {
    $self->specify_attr_list(@_);
  }

  $self;
}

=head3 clone

  my $temp=$attrs->clone();

Constructs a new object with the same settings as the current, and
returns it.

=cut

sub clone {
  my $this=shift;
  my $self=$this->new();

  $self->specify_attr_list($this->get_attr_list());

  $self;
}

=head3 set_std_attrs

  $attrs->set_std_attrs();

Set up the standard attributes

=cut

sub set_std_attrs {
  my $this=shift;

  $this->AddAttrGroup('single','double');

  # on linux-ia32, or Windows, the default is 32bit.  Otherwise, the
  # default is 64bit.
  my $os=$Config::Config{archname};
  if ($os=~m/i[3-6]86-linux/ or $os=~m/MSWin32-x86/) {
    $this->AddAttrGroup('32bit','64bit');
  } else {
    $this->AddAttrGroup('64bit','32bit');
  }

  $this->AddAttrGroup('int32','int64');
  $this->AddAttrGroup('archfort','ifort','pgfort','gnufort');
  $this->AddAttrGroup('optimised','debug');
  $this->AddAttrGroup('noprof','prof');
  $this->AddAttrGroup('lcomp','wbcomp');

  $this->init_std_attrs();
}

=head3 init_std_attrs

  $attrs->init_std_attrs();

Initialize the standard attributes to operational defaults, where
these are different from the defined default.

=cut

sub init_std_attrs {
  my $this = shift;

  # Note: To allow ALL solver executables to reside in compiler specific
  #       directories, partial_attr_list() must contain the relevant
  #       compiler specific attribute. The operational default attribute
  #       is therefore different from the default implied when creating
  #       the attribute group.

  my $os = $Config::Config{archname};
  if ($os =~ m/linux/) {
    $this->set_attr('ifort');
  }
}

=head2 INDIVIDUAL ATTRIBUTES

=head3 get_attr

  if ($a->get_attr('64bit')) {
    # ...
  } else {
    # $a->get_attr('32bit') is true ...
  }

Returns TRUE if the specified attribute is on, or FALSE if it is off.
This works similarly for inverse attributes.

=cut

sub get_attr
{
  my $this=shift;
  my $attr = shift;

  my $rgrps   = $this->{_attrgroups};
  my $rattrs  = $this->{_groupattrs};   
  my $rstates = $this->{_groupstates}; 

  unless ($this->IsValidAttr($attr)) {
    croak("No such attribute $attr (maybe need to call AddAttrGroup?)");
  } 

  my $group = $rgrps->{$attr};
  my $groupstate = $rstates->[$group];
  return $rattrs->[$group][$groupstate] eq $attr;
}

=head3 set_attr

  $a->set_attr('debug');
  # ...
  $a->set_attr('optimised');

Switches on the named attribute.
All other attributes in the group are switched off.

=cut

sub set_attr
{
  my $this=shift;
  my $attr = shift;

  my $rgrps   = $this->{_attrgroups};
  my $rattrs  = $this->{_groupattrs};   
  my $rstates = $this->{_groupstates}; 

  unless ($this->IsValidAttr($attr)) {
      croak("No such attribute $attr (maybe need to call AddAttrGroup?)");
  }
  
  my $group = $rgrps->{$attr};
  my $groupstate = $rstates->[$group];
  
  my $i = 0;
  for my $groupattr (@{ $rattrs->[$group] })
  {
    if ($groupattr eq $attr)
    {
      $rstates->[$group] = $i;
      last;
    }
    $i++;
  }  

  1;
}

=head3 clear_attr

  $a->set_attr('64bit');
  # ...
  $a->clear_attr('64bit');

Switches off the named attribute.  The opposite of C<set_attr>.

This function is primarily intended for use with attribute groups
containing two attributes. If there are more than two attributes in a
group, the default attribute will be set, ignoring any operational
defaults set by init_std_attrs().

=cut

sub clear_attr
{
  my $this=shift;
  my $attr = shift;

  my $rgrps   = $this->{_attrgroups};
  my $rattrs  = $this->{_groupattrs};   
  my $rstates = $this->{_groupstates}; 
  my $rdefs   = $this->{_groupdefaults};

  unless ($this->IsValidAttr($attr)) {
      croak("No such attribute $attr (maybe need to call AddAttrGroup?)");
  }  

  my $group = $rgrps->{$attr};
  my $groupstate = $rstates->[$group];

  # Only clear an attribute if it is already set
  if ($rattrs->[$group][$groupstate] eq $attr)
  {
    if (scalar(@{ $rattrs->[$group] }) > 2)
    {
      $rstates->[$group] = $rdefs->[$group];
    }
    else
    {
      my $state = 1;
      $state = 0 if ($rstates->[$group] == 1);
      $rstates->[$group] = $state;
    }
  }
  1;
}

=head2 ATTRIBUTE LISTS

As well as handling the attributes individually, we can handle the
"attribute strings" defined in the design.  The routines in this
section do this.  Each routine can take input either as a list of
individual attributes, or as a string separated with hyphens, so the
following are equivalent:

  $aa->specify_attr_list('double','nospag');
  $aa->specify_attr_list('double-nospag');

For the calls which return information, the return value will be a
list if called in list context, or the string form if called in scalar
context.

=head3 clear_attr_list

  $aa->clear_attr_list();

This call simply sets all attributes to their default values.

=cut

sub clear_attr_list
{
  my $this=shift;

  my $rattrs  = $this->{_groupattrs};   
  my $rstates = $this->{_groupstates}; 
  my $rdefs   = $this->{_groupdefaults};
 
  for (my $igroup=0; $igroup<scalar(@{$rattrs}); $igroup++)
  {
    $rstates->[$igroup] = $rdefs->[$igroup];
  }

  $this->init_std_attrs();

  1;
}

=head3 specify_attr_list

  $aa->specify_attr_list('double-nospag-64bit');

The C<specify_attr_list> call sets the entire attribute list to equal
what is supplied.  If an attribute is not included in the list, it
takes its default value.  This call is typically used when reading
from an external source which specifies the full attribute list of a
build.

This is equivalent to calling C<clear_attr_list> and then
C<merge_attr_list>.

=cut

sub specify_attr_list {
  my $self=shift;

  $self->clear_attr_list();
  $self->merge_attr_list(@_);
}

=head3 merge_attr_list

  $aa->merge_attr_list('double-nospag-64bit');

For each attribute in the list, set that attribute on this object.  If
the attribute is not included in the list, its former value is
unchanged.

=cut

sub merge_attr_list {
  my $self=shift;

  for my $a (@_) {
    if (not defined $a) {
      internal_error("Undefined attribute in list", 
                     map { defined $_ ? $_ : '(undef)' } @_);
    }
  }

  # just make it a list
  my @attrs=grep { $_ ne '' } map { split(/-/, $_) } @_;

  for my $a (@attrs) {
    $self->set_attr($a);
  }
  1;
}

=head3 get_attr_list

Returns the attribute list.

  @attr_list=$aa->get_attr_list();
  $attr_string=$aa->get_attr_list();

This list includes all selected attributes.
The order is the order in which they were added.

=cut

sub get_attr_list {
  my $this=shift;

  my $rattrs  = $this->{_groupattrs};   
  my $rstates = $this->{_groupstates}; 
  
  my @rv;
  for (my $i=0; $i<scalar(@{$rattrs}); $i++)
  {
    my $groupstate = $rstates->[$i];
    push @rv, $rattrs->[$i][$groupstate];
  }

  if (wantarray) {
    return @rv;
  } else {
    return join('-',@rv);
  }
}

=head3 partial_attr_list

This is just like C<get_attr_list>, but it only returns entries for
attributes which do not have their default value.

=cut

sub partial_attr_list {
  my $this=shift;

  my $rattrs  = $this->{_groupattrs};
  my $rstates = $this->{_groupstates};
  my $rdefs   = $this->{_groupdefaults};

  # now make a list
  my @rv;
  for (my $i=0; $i<scalar(@{$rattrs}); $i++)
  {
    my $groupstate = $rstates->[$i];
    unless ($groupstate == $rdefs->[$i])
    {
      push @rv, $rattrs->[$i][$groupstate];
    }
  }

  if (wantarray) {
    return @rv;
  } else {
    return join('-',@rv);
  }
}

=head3 type_attr_list

This call provides almost exactly the same functionality as
C<partial_attr_list>, but gives the value of the C<CFX5_ARCH_TYPE>
variable if that differs.  Currently, the difference is that the
C<CFX5_ARCH_TYPE> variable does not include the C<debug> attribute,
even if it is set.

=cut

sub type_attr_list {
  my $self=shift;
  my $new=$self->clone();
  $new->clear_attr('debug');
  $new->partial_attr_list();
}

=head3 opartial_attr_list

This call provides almost exactly the same functionality as
C<partial_attr_list>, but non default values are only included which
do not have their default or operational default value.

=cut

sub opartial_attr_list {
  my $self=shift;

  my $atts_default = CFX5::Attr->new();
  my %attrlist_default = map {$_ => 1} $atts_default->get_attr_list();
  my @rv = map {exists $attrlist_default{$_} ? () : $_} $self->get_attr_list();

  if (wantarray) {
    return @rv;
  } else {
    return join('-',@rv);
  }
}

=head2 STRINGIFICATION

=head3 display_text

Gives a short piece of descriptive text about this object.  Not
necessarily machine-parsable, but usable by humans.

=cut

sub display_text {
  my $self=shift;

  scalar($self->partial_attr_list());
}

=head2 UTILITY CLASS METHODS

Some quick convenience functions, for when the object interface is overkill.

=head3 MakeType

  my $subdir=CFX5::Attr->MakeType('32bit-double');

Returns the result of C<type_attr_list> on a new object created with
the argument as input.  This has the effect of removing default
attributes and re-ordering the rest, returning the correct
subdirectory name to check for on this platform.

=cut

sub MakeType {
  my $class=shift;
  my $obj=$class->new(@_);
  return $obj->type_attr_list();
}

=head2 GLOBAL CONFIG INTERFACE

Routines for manipulating the CFX5_ARCH_ATTRS and CFX5_ARCH_TYPE
variables.  These routines will signal an error if the C<CFX5::Config>
module is not loaded.

=head3 from_config

  my $attrs=CFX5::Attrs::from_config();
  # modify $attrs
  $attrs->to_config();

or

  $attrs->from_config();

The C<from_config> call reads the current settings of the
C<CFX5_ARCH_ATTRS> variable, and constructs a new C<CFX5::Attr> object
from them.  If called as an object method, it sets the current object
based on the variable.

It will also set the C<CFX5_ARCH_TYPE> variable based on the current
settings of the C<CFX5_ARCH_ATTRS> variable.

=cut

sub from_config {
  my $self=shift;
  $self=new CFX5::Attr unless ref($self);
  if (defined &CFX5::Config::getconf) {
    my $new=&CFX5::Config::getconf('CFX5_ARCH_ATTRS');
    $new='' unless defined $new;
    $self->specify_attr_list($new);
    $self->to_config();
  } else {
    die "The from_config method only makes sense if the CFX5::Config module is loaded!"
  }
  $self;
}

=head3 to_config

  my $attrs=CFX5::Attrs::from_config();
  # modify $attrs
  $attrs->to_config();

The C<to_config> call sets the C<CFX5_ARCH_ATTRS> and
C<CFX5_ARCH_TYPE> variables from the object it is called on.

=cut

sub to_config {
  my $self=shift;
  if (defined &CFX5::Config::setconf) {
    &CFX5::Config::setconf(CFX5_ARCH_ATTRS => scalar($self->get_attr_list()));
    &CFX5::Config::setconf(CFX5_ARCH_TYPE => scalar($self->type_attr_list()));
  } else {
    die "The to_config method only makes sense if the CFX5::Config module is loaded!"
  }
  $self;
}

1;
