#!/nw/dev/usr/bin/perl -w

use strict;
use Symbol;
use builtin qw(min max);
use Fatal qw(open);
use ObjStore::REP::HashRecord qw($VERSION c_types $Fspec %align);

my $input;
for (my $arg=0; $arg < @ARGV; $arg++) {
    my $o = $ARGV[$arg];
    # no options yet;
    if ($input) {
	warn "$o ignored";
	next;
    } else {
	if ($o =~ s/.rec$//) {
	    $input = $o;
	} else {
	    warn "expecting $o.rec suffix";
	    $input = $o;
	}
    }
}

my ($C,$H) = (gensym,gensym);
my $rec = gensym;
open $rec, "$input.rec";

open $C, ">$input.c";
open $H, ">$input.h";

sub preamble {
    my $fh = shift;
    print $fh "// Yucky -*-C++-*- generated by HashRecord $VERSION at ".localtime()."\n";
    print $fh "//\n";
    print $fh "// DO NOT EDIT THIS FILE;\n";
    print $fh "//   ALL CHANGES WILL BE OVERWRITTEN!!\n";
    print $fh "//\n\n";
}

for ($C,$H) { preamble($_) }

print $H qq[#include "osp_hashrecord.h"\n];
print $C q[extern "C" {
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
}
#include <stddef.h>
];
print $C qq[#include "$input.h"\n\n];

my $class_RE = '(class|struct)\s+';

my %T;
for (c_types) { $T{$_} = 1 }

my %opt = (readonly => 0, index => 1, os_class => 1);
my $Class;
my $NextId;
my $fallback;
my @F;
my $l;
while ($l = <$rec>) {
    if ($l =~ m/$class_RE (\w+) \s [^;\{]* \{ /x) {
	print $H "// HR options: ".join(' ', map { ($opt{$_}?'':'!') . $_ }
					sort keys %opt)."\n";
	$Class = $2;
	$NextId = 0;
	next
    }
    if ($l =~ m/^\}\;/) {
	if (! @F) {
#	    warn "$Class has no recognizable fields (ignored)";
	} else {
	    generate($Class, \@F);
	}
	$Class = undef;
	$fallback = undef;
	@F=();
	next
    }
    if (!$Class and $l =~ m{ ^ // \s* HR \s+ options: \s+ (.*) $ }x) {
	my @opt = split /\s+/, $1;
	for my $o (@opt) {
	    if ($o =~ m/^(\!)?readonly$/) {
		$opt{readonly} = ! $1;
	    } elsif ($o =~ m/^(\!)?index$/) {
		$opt{index} = ! $1;
	    } elsif ($o =~ m/^(\!)?os_class$/) {
		$opt{os_class} = ! $1;
	    } else {
		warn "unknown option '$o' ignored";
	    }
	}
	$l = '';
	next;
    }
    next if !$Class;
    next if $l =~ m/^\s*$/;

    if ($l =~ /^alias: \s+ (\w+) \s+ (\w+) \s* $/x) {
	my ($one,$to) = ($1,$2);
	my $ok=0;
	for my $f (@F) {
	    next if $f->{name} ne $to;
	    my %copy = %$f;
	    delete $copy{'align'};
	    delete $copy{'text'};
	    push @F, { %copy, name => $one, len => length $one, alias => $to };
	    $ok=1;
	    last;
	}
	$l = '';
	warn "alias: '$to' not found (ignored)"
	    if !$ok;
	next;
    }

    my @l = split /\s+/, $l;
    shift @l if !length $l[0];
    $l[0] =~ s/^I(\d+)$/os_int$1/;
    next if (!exists $T{ $l[0] } or
	     $l[1] !~ s/^ (\w+) (\;)? $/$1/x);
    my $rest = join(' ', @l[2..$#l]);
    my $id = $NextId++;
    my $name = $l[1];
    $name = $1 if $rest =~ /\b rename\: \s (\w+) \b/x;
    $fallback = $l[1] if $name eq 'FALLBACK' && $l[0] eq 'OSPVptr';
    chop $l;
    $l .= "\t//" if $l !~ m'//';
    $l .= ' @'.$id;
    $l .= "\n";
    push @F, { type => $l[0], align => $align{$l[0]},
	       cname => $l[1], name => $name,
	       len => length $name, id => $id, text => $l };
    $l='';
} continue {
    print $H $l if $l;
}

sub generate {
    my ($class,$F) = @_;

    # HEADER FILE
    my @real = grep { !exists $_->{alias} } @$F;
    my @alias = grep { exists $_->{alias} } @$F;
    my $cnt = @$F;
    my $bset = int ((31+@real)/32);
    if ($bset > 4) {
	warn "too many fields $bset > 128";
	$bset = 4;
    }
    print $H "// HR fields:\n";

    # re-order fields as little as possible
    for (my $al = max map { $_->{align} } @real; $al > 0; $al--) {
	for (grep { $_->{align} == $al } @real) {
	    print $H $_->{text};
	}
	if ($al == 4) {
	    print $H "    osp_bitset$bset HR_readonly; // HR\n"
		if $opt{readonly};
	    print $H "    osp_bitset$bset HR_indexed; // HR\n"
		if $opt{index};
	}
    }
    my $osc = $opt{os_class}? '':'//';

    print $H <<END;

  // HashRecord class info:
  static int HR_all_fields, HR_real_fields;
  static $Fspec HR_spec[$cnt];
  static HV* HR_field_map;
  static int HR_warn_noise;

  // HashRecord methods:
  virtual void make_constant();
  virtual int HR_get_num_fields();
  virtual int HR_key_2field(char *key, int klen);
  virtual $Fspec *HR_get_field_spec(int xx);
  virtual int HR_mod_field(int xx);
  virtual void HR_mod_field(osp_pathexam &exam, int xx);

  // you must implement:
  $osc virtual char *os_class(STRLEN *len);
END

    # FIELD SPEC TABLE
    print $C "osp_hashrec_field_spec $class\::HR_spec[$cnt] = {\n  ";
    print $C join(",\n  ",
		  map { "{ ".join(', ',
				  $_->{id},
				  qq["$_->{name}"],
				  length $_->{name},
				  "offsetof($class, $_->{cname})",
				  "FT_".$_->{type},
				  $_->{alias}? qq["$_->{alias}"]:0
				 )." }" }
		  (sort { $a->{id} <=> $b->{id} } @real), @alias);
    print $C "\n};\n";
    print $C "int $class\::HR_all_fields = $cnt;\n";
    print $C "int $class\::HR_real_fields = ".(0+@real).";\n";
    print $C "\n";

    # METHODS
    print $C "void $class\::make_constant()\n";
    if ($opt{readonly}) {
	print $C "{ HR_readonly.set(); }\n";
    } else {
	print $C "{ OSPvFLAGS(this) |= OSPV_phrREADONLY; }\n";
    }
    print $C "int $class\::HR_get_num_fields() { return HR_real_fields; }\n";
    print $C "$Fspec * $class\::HR_get_field_spec(int xx)\n{ return &HR_spec[xx]; }\n";
    if ($fallback) {
	print $H "  OSSVPV *HR_get_fallback();\n";
	print $C "OSSVPV *$class\::HR_get_fallback() { return $fallback; }\n";
    }
    print $C "int $class\::HR_mod_field(int xx)\n";
    print $C "{\n";
    print $C "  if (HR_indexed[xx]) return 0;\n" if $opt{index};
    if ($opt{readonly}) {
	print $C "  if (HR_readonly[xx]) return 0;\n";
    } else {
	print $C "  if (OSPvFLAGS(this) & OSPV_phrREADONLY) return 0;\n";
    }
    print $C "  return 1;\n";
    print $C "}\n";
    print $C "void $class\::HR_mod_field(osp_pathexam &exam, int xx)\n";
    print $C "{\n";
    if ($opt{index}) {
	if ($opt{readonly}) {
	    print $C "  if (HR_readonly[xx]) return;\n";
	} else {
	    print $C "  if (OSPvFLAGS(this) & OSPV_phrREADONLY) return;\n";
	}
	print $C "  if (exam.get_mode() == 's') {\n";
	print $C "    if (HR_indexed[xx]) exam.set_conflict();\n";
	print $C "    else HR_indexed.set(xx);\n";
	print $C "  } else if (exam.get_mode() == 'u') HR_indexed.clr(xx);\n";
    } else {
	# !index
	print $C "  if (exam.get_mode() == 's') {\n";
	if ($opt{readonly}) {
	    print $C "    HR_readonly.set(xx);\n";
	} else {
	    print $C "    OSPvFLAGS(this) |= OSPV_phrREADONLY;\n";
	}
	print $C "  }\n";
    }
    print $C "}\n";
    print $C "HV* $class\::HR_field_map=0;\n";
    print $C "int $class\::HR_warn_noise=7;\n";
    print $C qq[
int $class\::HR_key_2field(char *key, int klen)
{
  if (!klen) klen = strlen(key);
  if (!HR_field_map) {
      HR_field_map = newHV();
      for (int xx=0; xx < HR_all_fields; xx++) {
	  hv_store(HR_field_map, HR_spec[xx].key, HR_spec[xx].keylen,
		   newSViv(xx), 0);
      }
  }
  SV **sv = hv_fetch(HR_field_map, key, klen, 0);
  if (!sv) return -1;
  int ret = SvIVX(*sv);
  if (HR_spec[ret].alias_to && --$class\::HR_warn_noise > 0)
      warn("Please use '%s' instead of '%s'",
	   HR_spec[ret].alias_to, HR_spec[ret].key);
  return HR_spec[ret].id;
}
];
    print $C "\n";
}

# verify binary footprint size < 1-5k per class

__END__;