[ViewVC] Annotation of: cvs/deliantra/server/server/genacc

#! perl

# actually geninterface

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

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

   while (<$fh>) {
      if ($curclass eq $class) {
         while (/ACC\s*\(R([WO])\s*,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) {
            if ($3) {
               push @array_member, [$1, $2, $3];
            } else {
               push @scalar_member, [$1, $2];
            }
         }
         if (/MTH \s+ ([^(]*?) \s* ([A-Za-z_0-9]+) \s* \(([^)]*)\)/x) {
            push @method_member, [$1, $2, $3];
         }
      }
      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";
}

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

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

   print "\tCODE:\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->$scalar_member[$_][1]); break;\n",
             0 .. $#scalar_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->$scalar_member[$_][1]); break;\n",
             grep $scalar_member[$_][0] eq "W",
                0 .. $#scalar_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$array_member[$_][1]\t= $_\n";
      }
   }

   print "\tCODE:\n";

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

# range
   print "\t  switch (ix)\n",
         "\t    {\n",
         (map "\t      case $_: if (idx >= $array_member[$_][2]) 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";
}

Revision:	1.5
Committed:	Sat Dec 30 10:16:11 2006 UTC (17 years, 5 months ago) by root
Branch:	MAIN
Changes since 1.4:	+33 -7 lines
Log Message:	preliminary snapshot check-in, DO NOT USE IN PRODUCTION SYSTEMS See the Changes file for details
#	User	Rev	Content
1	root	1.1	#! perl
2
3	root	1.4	# actually geninterface
4
5	root	1.1	my $class = shift;
6			my $curclass = "";
7	root	1.3	my (@scalar_member, @array_member);
8	root	1.1
9			for my $file (@ARGV) {
10			open my $fh, "<:utf8", $file
11			or die "$file: $!";
12
13			while (<$fh>) {
14	root	1.5	if ($curclass eq $class) {
15			while (/ACC\s\(R([WO])\s,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) {
16			if ($3) {
17			push @array_member, [$1, $2, $3];
18			} else {
19			push @scalar_member, [$1, $2];
20			}
21			}
22			if (/MTH \s+ ([^(]?) \s ([A-Za-z_0-9]+) \s* \(([^)]*)\)/x) {
23			push @method_member, [$1, $2, $3];
24	root	1.3	}
25	root	1.1	}
26	root	1.4	while (/INTERFACE_CLASS\s*\((\S+)\)/g) {
27	root	1.1	$curclass = $1;
28			}
29			}
30			}
31
32	root	1.5	for (@method_member) {
33			my ($rettype, $name, $params) = @$_;
34
35			if ($rettype =~ s/static\s+//) {
36			my $args = join ", ", $params =~ m/.?([a-zA-Z_0-9]+)(?:,\s\|$)/g;
37			if ($rettype ne "void") {
38			print "$rettype\n$name ($params)\n",
39			"\tCODE:\n",
40			"\tRETVAL = $class\::$name ($args);\n",
41			"\tOUTPUT:\n",
42			"\tRETVAL\n";
43			} else {
44			print "$rettype\n$name ($params)\n",
45			"\tCODE:\n",
46			"\t$class\::$name ($args);\n",
47			}
48			} else {
49			print "$rettype\n$class\::$name ($params)\n";
50			}
51
52			print "\n";
53			}
54
55	root	1.3	if (@scalar_member) {
56			print "SV $scalar_member[0][1] ($class self, SV *newval = 0)\n";
57			print "\tPROTOTYPE: \$;\$\n";
58
59			if (@scalar_member > 1) {
60			print "\tALIAS:\n";
61			for (1 .. $#scalar_member) {
62			print "\t\t$scalar_member[$_][1]\t= $_\n";
63			}
64			}
65	root	1.1
66	root	1.3	print "\tCODE:\n";
67
68			# read
69			print "\tif (GIMME_V == G_VOID)\n",
70			"\t RETVAL = &PL_sv_undef;\n",
71			"\telse\n",
72			"\t switch (ix)\n",
73			"\t {\n",
74			(map "\t case $_: RETVAL = to_sv (self->$scalar_member[$_][1]); break;\n",
75			0 .. $#scalar_member),
76			"\t default: croak (\"scalar_member is write-only\");\n",
77			"\t };\n";
78	root	1.1
79	root	1.3	# write
80			print "\tif (newval)\n",
81			"\t switch (ix)\n",
82			"\t {\n",
83			(map "\t case $_: sv_to (newval, self->$scalar_member[$_][1]); break;\n",
84			grep $scalar_member[$_][0] eq "W",
85			0 .. $#scalar_member),
86			"\t default: croak (\"scalar_member is read-only\");\n",
87			"\t };\n";
88
89			print "\tOUTPUT: RETVAL\n\n";
90			}
91
92			if (@array_member) {
93			print "SV $array_member[0][1] ($class self, int idx, SV *newval = 0)\n";
94			print "\tPROTOTYPE: \$;\$\n";
95
96			if (@array_member > 1) {
97			print "\tALIAS:\n";
98			for (1 .. $#array_member) {
99			print "\t\t$array_member[$_][1]\t= $_\n";
100			}
101	root	1.1	}
102
103	root	1.3	print "\tCODE:\n";
104
105			print "\tif (idx < 0) croak (\"negative array index\");\n";
106
107			# range
108			print "\t switch (ix)\n",
109			"\t {\n",
110			(map "\t case $_: if (idx >= $array_member[$_][2]) croak (\"array index out of bounds\"); break;\n",
111			0 .. $#array_member),
112			"\t };\n";
113	root	1.1
114			# read
115	root	1.3	print "\tif (GIMME_V == G_VOID)\n",
116			"\t RETVAL = &PL_sv_undef;\n",
117			"\telse\n",
118			"\t switch (ix)\n",
119			"\t {\n",
120			(map "\t case $_: RETVAL = to_sv (self->$array_member[$_][1] [idx]); break;\n",
121			0 .. $#array_member),
122			"\t default: croak (\"array_member is write-only\");\n",
123			"\t };\n";
124	root	1.1
125			# write
126	root	1.3	print "\tif (newval)\n",
127			"\t switch (ix)\n",
128			"\t {\n",
129			(map "\t case $_: sv_to (newval, self->$array_member[$_][1] [idx]); break;\n",
130			grep $array_member[$_][0] eq "W",
131			0 .. $#array_member),
132			"\t default: croak (\"array_member is read-only\");\n",
133			"\t };\n";
134	root	1.1
135	root	1.3	print "\tOUTPUT: RETVAL\n\n";
136			}
137	root	1.1