#! perl

#
# This file is part of Deliantra, the Roguelike Realtime MMORPG.
#  
# Copyright (©) 2005,2006,2007,2008,2009 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
#  
# Deliantra is free software: you can redistribute it and/or modify it under
# the terms of the Affero GNU General Public License as published by the
# Free Software Foundation, either version 3 of the License, or (at your
# option) any later version.
#  
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#  
# You should have received a copy of the Affero GNU General Public License
# and the GNU General Public License along with this program. If not, see
# <http://www.gnu.org/licenses/>.
#  
# The authors can be reached via e-mail to <support@deliantra.net>
# 

# used to automatically create accessors/mutators and method interfaces
# to C++ classes for Perl.
# also write data structures as JSON object, for reflection

use JSON::XS;

my $class = shift;
my $curclass = "";
my (@scalar_member, @array_member);

# convert c member name to perl
sub c2perl($) {
   local $_ = shift;

   s/^([^.]+)\.\1_/$1\_/g; # tcpi.tcpi_xxx => tcpi_xxx

   $_
}

for my $file (@ARGV) {
   open my $fh, "<:utf8", $file
      or die "$file: $!";

   while (<$fh>) {
      next if /^\s*\//; # skip lines starting with /
      if ($curclass eq $class) {
         while (/ACC\s*\(R([WO])\s*,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) {
            my ($access, $name, $count) = ($1, $2, $3);
            my $static = /\bstatic\b/;
            if ($count) {
               die "static array members not yet supported by genacc" if $static;
               push @array_member, [$access, $name, $static, $count];
            } else {
               push @scalar_member, [$access, $name, $static];
            }
         }
         if (/MTH \s+ ([^(]*?) \s* ([A-Za-z_0-9]+) \s* \(([^)]*)\)/x) {
            my ($retval, $name, $args) = ($1, $2, $3);
            push @method_member, [$retval, $name, $args];
         }
      }
      while (/INTERFACE_CLASS\s*\((\S+)\)/g) {
         $curclass = $1;
      }
   }
}

for (@method_member) {
   my ($rettype, $name, $params) = @$_;

   if ($rettype =~ s/static\s+//) {
      my $args = join ", ", $params =~ m/.*?([a-zA-Z_0-9]+)(?:,\s*|$)/g;
      if ($rettype ne "void") {
         print "$rettype\n$name ($params)\n",
               "\tCODE:\n",
               "\tRETVAL = $class\::$name ($args);\n",
               "\tOUTPUT:\n",
               "\tRETVAL\n";
      } else {
         print "$rettype\n$name ($params)\n",
               "\tCODE:\n",
               "\t$class\::$name ($args);\n",
      }
   } else {
      print "$rettype\n$class\::$name ($params)\n";
   }

   print "\n";
}

for my $static (0, 1) {
   my @member = grep $static == $_->[2], @scalar_member;

   if (@member) {
      my $self;
      if ($static) {
         $self = "$class\::";
         print "SV *$member[0][1] (SV *newval = 0)\n",
               "\tPROTOTYPE: ;\$\n";
      } else {
         $self = "self->";
         print "SV *$member[0][1] ($class *self, SV *newval = 0)\n",
               "\tPROTOTYPE: \$;\$\n";
      }

      if (@member > 1) {
         print "\tALIAS:\n";
         for (1 .. $#member) {
            print "\t\t" . (c2perl $member[$_][1]) . "\t= $_\n";
         }
      }

      print "\tCODE:\n";

      my $ix = @member == 1 ? 0 : "ix";

# read
      print "\tif (GIMME_V == G_VOID)\n",
            "\t  RETVAL = &PL_sv_undef;\n",
            "\telse\n",
            "\t  switch ($ix)\n",
            "\t    {\n",
            (map "\t      case $_: RETVAL = to_sv ($self$member[$_][1]); break;\n",
                0 .. $#member),
            "\t      default: croak (\"scalar_member is write-only\");\n",
            "\t    };\n";

# write
      print "\tif (newval)\n",
            "\t  switch ($ix)\n",
            "\t    {\n",
            (map "\t      case $_: sv_to (newval, $self$member[$_][1]); break;\n",
                grep $member[$_][0] eq "W",
                   0 .. $#member),
            "\t      default: croak (\"scalar_member is read-only\");\n",
            "\t    };\n";

      print "\tOUTPUT: RETVAL\n\n";
   }
}

if (@array_member) {
   print "SV *$array_member[0][1] ($class *self, int idx, SV *newval = 0)\n";
   print "\tPROTOTYPE: \$;\$\n";

   if (@array_member > 1) {
      print "\tALIAS:\n";
      for (1 .. $#array_member) {
         print "\t\t" . (c2perl $array_member[$_][1]) . "\t= $_\n";
      }
   }

   print "\tCODE:\n";

   print "\tif (idx < 0) croak (\"negative array index\");\n";

   my $ix = @array_member == 1 ? 0 : "ix";

# range
   print "\t  switch ($ix)\n",
         "\t    {\n",
         (map "\t      case $_: if (idx >= $array_member[$_][3]) croak (\"array index out of bounds\"); break;\n",
             0 .. $#array_member),
         "\t    };\n";

# read
   print "\tif (GIMME_V == G_VOID)\n",
         "\t  RETVAL = &PL_sv_undef;\n",
         "\telse\n",
         "\t  switch ($ix)\n",
         "\t    {\n",
         (map "\t      case $_: RETVAL = to_sv (self->$array_member[$_][1] [idx]); break;\n",
             0 .. $#array_member),
         "\t      default: croak (\"array_member is write-only\");\n",
         "\t    };\n";

# write
   print "\tif (newval)\n",
         "\t  switch ($ix)\n",
         "\t    {\n",
         (map "\t      case $_: sv_to (newval, self->$array_member[$_][1] [idx]); break;\n",
             grep $array_member[$_][0] eq "W",
                0 .. $#array_member),
         "\t      default: croak (\"array_member is read-only\");\n",
         "\t    };\n";

   print "\tOUTPUT: RETVAL\n\n";
}

my $json = JSON::XS->new->utf8->encode ({
   class   => $class,
   methods => { map +($_->[1], [$_->[0], $_->[2]]), @method_member },
   scalars => { map +($_->[1], [$_->[0]         ]), @scalar_member },
   arrays  => { map +($_->[1], [$_->[0], $_->[2]]), @array_member },
});

$json = join "\n", map {
           my $part = $_;
           $part =~ s/(["\\])/\\$1/g;
           "\"$part\""
        } unpack "(a80)*", $json;

print "BOOT:\n",
      "\tav_push (av_reflect, newSVpv ($json, 0));\n\n";