package Entity;

require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw(
  %ENTITY
  get_env
  split_number
  set_string
  set_num
  set_num_diff
  check
  check_eq
  parse_file
  write_sh_variables
);

use strict;

#
# global variables
#
use vars qw( %ENTITY $GLOBAL_PRE );

$GLOBAL_PRE = 'TEVWH_';

my $GENERATED = 'Generated by configure.pl, do not edit.';
my $HAVE_PRE = $GLOBAL_PRE . 'HAVE_';

#
# get_env
#
sub get_env($)
{
  my $name = shift;
  my $val = $ENV{$name}
  || die "Environment variable '$name' not defined.";
  return $val;
}

#
# set_string
#
sub set_string($$)
{
  my $base = shift;
  my $string = shift;

  $string =~ s/\s+$//;
  $ENTITY{$base} = $string;
}

#
# set_num
#
sub set_num($$)
{
  my $base = shift;
  my $num = shift;

  $num =~ s/\s+$//;
  return if ($num < 0);
  $ENTITY{$base . '.D'} = $num;
  $ENTITY{$base . '.X'} = sprintf('0x%x', $num);
}

#
# set_num_diff
#
sub set_num_diff($$$)
{
  set_num shift, check(shift) - check(shift);
}

#
# split_number
#
sub split_number($)
{
  my @n = split(/\s+/, shift());

  # this is necessary for SunOS 5.7 where objdump insists on
  # writing 64-bit even for 32-bit executables
  for my $n(@n) { $n =~ s/^0x0+([0-9a-fA-f])/0x$1/; }
  return @n;
}

#
# check
#
sub check($;$)
{
  my $name = shift;
  my $value = shift;

  my $actual = $ENTITY{$name};
  die "!defined(\$ENTITY{\'$name\'})" if (!defined($actual));

  return $actual if (!defined($value) || $actual == $value);
  my $msg = sprintf "\$ENTITY{%s} == %d, not %d (%#x != %#x)\n",
    $name, $actual, $value, $actual, $value;
  die $msg;
}

#
# check_eq
#
sub check_eq($;$)
{
  my $name = shift;
  my $value = shift;

  my $actual = $ENTITY{$name};
  die "!defined(\$ENTITY{\'$name\'})" if (!defined($actual));

  return $actual if (!defined($value) || $actual eq $value);
  die "\$ENTITY{$name} == $actual, not $value\n";
}

#
# parse_file
#
sub parse_file($$;@)
{
  my $fn = shift;
  my $filename = shift;

  open(FILE, $filename) || return "Can't open $filename: $!";
  my @line;
  while(<FILE>)
  {
    s/\s*$//;
    push @line, $_;
  }
  close FILE;
  return "$filename is empty\n" if ($#line < 0);

  $fn = '::' . $fn if (!($fn =~ m/::/));
  my $ref = eval "\\&$fn";

  my $msg = &$ref(\@line, @_, $filename);
  return undef if (!defined($msg));
  return "$fn(\"$filename\"): $msg\n";
}

#
# open_config_file
#
sub open_config_file($$;$$)
{
  my $FILE = shift;
  my $name = shift;
  my $header_pre = shift;
  my $header_post = shift;

  $header_pre = '# ' if (!defined($header_pre));
  $header_post = '' if (!defined($header_post));

  open($FILE, '>' . $name) || die "Can't open $name for writing: $!";
  printf $FILE "%sGenerated by configure.pl, do not edit.%s\n\n",
    $header_pre, $header_post;
}

#
# open_xml_file
#
sub open_xml_file($$)
{
  open_config_file(shift(), shift(), '<!-- ', ' -->');
}

#
# write_sh_variables
#
sub write_sh_variables($$$$$$$;$)
{
  my $r_hash = shift;
  my $SH = shift;
  my $CSH = shift;
  my $MAK = shift;
  my $SED = shift;
  my $H = shift;
  my $XML = shift;
  my $prefix = shift;
  $prefix = '' if (!defined($prefix));

  my $entity_pre = 'config.' . $prefix;
  $entity_pre =~ y#-/_#.#;

  my $path_pre = $GLOBAL_PRE . $prefix;
  my $have_pre = $HAVE_PRE . $prefix;

  my $export = "\nexport";

  while (my ($entity, $value) = each %$r_hash)
  {
    die "\$r_hash{$entity} is undefined." if (!defined($value));
    my $name = $GLOBAL_PRE . $prefix . $entity;

    printf $H "#define %s %s\n", $name, $value;

    # Hexadecimal values are output without leading '0x' to enable
    # echo "ibase=16; ELF_BASE" | bc
    $value =~ s/^0x(\d+)$/$1/;

    printf $SH "%s='%s'\n", $name, $value;
    $export .= ' ' . $name;
    printf $CSH "setenv %s '%s'\n", $name, $value;
    printf $MAK "%s=%s\n", $name, $value;
    printf $MAK "%s=%s\n", $have_pre . $entity, lc($entity);

    $entity =~ y#-/_#.#;
    printf $XML "<!ENTITY %s%s \"%s\">\n", $entity_pre, $entity, $value;

    $value =~ s/([#\\\[\]])/\\$1/g;
    printf $SED "s#\${%s}#%s#g\n", $name, $value;
  }

  print $SH $export . "\n\n";
}

#
# write_xml_table
#
sub write_xml_table($$;$@)
{
  my $FILE = shift;
  my $r_hash = shift;
  my $prefix = shift;
  $prefix = '' if (!defined($prefix));

  my %hash = %$r_hash;
  for my $key(@_) { delete $hash{$key}; }

  print $FILE <<BLOCK_1;
<tgroup cols="4">
  <thead>
    <row>
      <entry>Variable name</entry>
      <entry>Value on this platform</entry>
      <entry>Variable name</entry>
      <entry>Value on this platform</entry>
    </row>
  </thead>
  <tbody><row>
BLOCK_1

  my @key = sort(keys(%hash));
  my $i = 0;
  for my $key(@key)
  {
    printf $FILE "  </row><row>\n" if ($i % 2 == 0 && $i > 0);
    printf $FILE "    <entry><literal>%s%s</literal></entry>\n",
      $prefix, $key;
    printf $FILE "    <entry><literal>%s</literal></entry>\n",
      $hash{$key};
    $i++;
  }

  printf $FILE "  </row></tbody>\n</tgroup>\n";
}

1;
