[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>) {
      while (/ACC\s*\(R([WO])\s*,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) {
         next unless $curclass eq $class;

         if ($3) {
            push @array_member, [$1, $2, $3];
         } else {
            push @scalar_member, [$1, $2];
         }
      }
      while (/INTERFACE_CLASS\s*\((\S+)\)/g) {
         $curclass = $1;
      }
   }
}

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.4
Committed:	Mon Dec 25 11:25:49 2006 UTC (17 years, 5 months ago) by root
Branch:	MAIN
Changes since 1.3:	+3 -1 lines
Log Message:	- small, but subtle, rewrite of object management - perl will now keep attachable objects alive - objects are now refcounted - refcouts need to be tested explicitly (refcnt_chk) - explicit destroy is required current - explicit destroy asks "nicely" for the object to self destruct, if possible - refcounts will be used during mortal killing - minor bugfixes, optimisations etc. - some former hacks removed.
#	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.3	while (/ACC\s\(R([WO])\s,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) {
15	root	1.1	next unless $curclass eq $class;
16
17	root	1.3	if ($3) {
18			push @array_member, [$1, $2, $3];
19			} else {
20			push @scalar_member, [$1, $2];
21			}
22	root	1.1	}
23	root	1.4	while (/INTERFACE_CLASS\s*\((\S+)\)/g) {
24	root	1.1	$curclass = $1;
25			}
26			}
27			}
28
29	root	1.3	if (@scalar_member) {
30			print "SV $scalar_member[0][1] ($class self, SV *newval = 0)\n";
31			print "\tPROTOTYPE: \$;\$\n";
32
33			if (@scalar_member > 1) {
34			print "\tALIAS:\n";
35			for (1 .. $#scalar_member) {
36			print "\t\t$scalar_member[$_][1]\t= $_\n";
37			}
38			}
39	root	1.1
40	root	1.3	print "\tCODE:\n";
41
42			# read
43			print "\tif (GIMME_V == G_VOID)\n",
44			"\t RETVAL = &PL_sv_undef;\n",
45			"\telse\n",
46			"\t switch (ix)\n",
47			"\t {\n",
48			(map "\t case $_: RETVAL = to_sv (self->$scalar_member[$_][1]); break;\n",
49			0 .. $#scalar_member),
50			"\t default: croak (\"scalar_member is write-only\");\n",
51			"\t };\n";
52	root	1.1
53	root	1.3	# write
54			print "\tif (newval)\n",
55			"\t switch (ix)\n",
56			"\t {\n",
57			(map "\t case $_: sv_to (newval, self->$scalar_member[$_][1]); break;\n",
58			grep $scalar_member[$_][0] eq "W",
59			0 .. $#scalar_member),
60			"\t default: croak (\"scalar_member is read-only\");\n",
61			"\t };\n";
62
63			print "\tOUTPUT: RETVAL\n\n";
64			}
65
66			if (@array_member) {
67			print "SV $array_member[0][1] ($class self, int idx, SV *newval = 0)\n";
68			print "\tPROTOTYPE: \$;\$\n";
69
70			if (@array_member > 1) {
71			print "\tALIAS:\n";
72			for (1 .. $#array_member) {
73			print "\t\t$array_member[$_][1]\t= $_\n";
74			}
75	root	1.1	}
76
77	root	1.3	print "\tCODE:\n";
78
79			print "\tif (idx < 0) croak (\"negative array index\");\n";
80
81			# range
82			print "\t switch (ix)\n",
83			"\t {\n",
84			(map "\t case $_: if (idx >= $array_member[$_][2]) croak (\"array index out of bounds\"); break;\n",
85			0 .. $#array_member),
86			"\t };\n";
87	root	1.1
88			# read
89	root	1.3	print "\tif (GIMME_V == G_VOID)\n",
90			"\t RETVAL = &PL_sv_undef;\n",
91			"\telse\n",
92			"\t switch (ix)\n",
93			"\t {\n",
94			(map "\t case $_: RETVAL = to_sv (self->$array_member[$_][1] [idx]); break;\n",
95			0 .. $#array_member),
96			"\t default: croak (\"array_member is write-only\");\n",
97			"\t };\n";
98	root	1.1
99			# write
100	root	1.3	print "\tif (newval)\n",
101			"\t switch (ix)\n",
102			"\t {\n",
103			(map "\t case $_: sv_to (newval, self->$array_member[$_][1] [idx]); break;\n",
104			grep $array_member[$_][0] eq "W",
105			0 .. $#array_member),
106			"\t default: croak (\"array_member is read-only\");\n",
107			"\t };\n";
108	root	1.1
109	root	1.3	print "\tOUTPUT: RETVAL\n\n";
110			}
111	root	1.1