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

#! perl

# used to automatically create accessors/mutators and method interfaces
# to C++ classes for Perl.

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) {
            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" . (c2perl $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" . (c2perl $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.8
Committed:	Sat Jul 28 00:15:03 2007 UTC (16 years, 10 months ago) by root
Branch:	MAIN
CVS Tags:	rel-2_6, rel-2_4, rel-2_5, rel-2_2, rel-2_3, rel-2_54, rel-2_55, rel-2_56, rel-2_52, rel-2_53, rel-2_32, rel-2_61, rel-2_43, rel-2_42, rel-2_41
Changes since 1.7:	+11 -2 lines
Log Message:	allow perl access to the full tcpi structure. do some elaborate congestion control (very experimental, but better than the old way)
#	User	Rev	Content
1	root	1.1	#! perl
2
3	root	1.7	# used to automatically create accessors/mutators and method interfaces
4			# to C++ classes for Perl.
5	root	1.4
6	root	1.1	my $class = shift;
7			my $curclass = "";
8	root	1.3	my (@scalar_member, @array_member);
9	root	1.1
10	root	1.8	# convert c member name to perl
11			sub c2perl($) {
12			local $_ = shift;
13
14			s/^([^.]+)\.\1_/$1\_/g; # tcpi.tcpi_xxx => tcpi_xxx
15
16			$_
17			}
18
19	root	1.1	for my $file (@ARGV) {
20			open my $fh, "<:utf8", $file
21			or die "$file: $!";
22
23			while (<$fh>) {
24	root	1.6	next if /^\s*\//; # skip lines starting with /
25	root	1.5	if ($curclass eq $class) {
26			while (/ACC\s\(R([WO])\s,\s*([^)\]]+)(?:\[(\S+)\])?\)/g) {
27			if ($3) {
28			push @array_member, [$1, $2, $3];
29			} else {
30			push @scalar_member, [$1, $2];
31			}
32			}
33			if (/MTH \s+ ([^(]?) \s ([A-Za-z_0-9]+) \s* \(([^)]*)\)/x) {
34			push @method_member, [$1, $2, $3];
35	root	1.3	}
36	root	1.1	}
37	root	1.4	while (/INTERFACE_CLASS\s*\((\S+)\)/g) {
38	root	1.1	$curclass = $1;
39			}
40			}
41			}
42
43	root	1.5	for (@method_member) {
44			my ($rettype, $name, $params) = @$_;
45
46			if ($rettype =~ s/static\s+//) {
47			my $args = join ", ", $params =~ m/.?([a-zA-Z_0-9]+)(?:,\s\|$)/g;
48			if ($rettype ne "void") {
49			print "$rettype\n$name ($params)\n",
50			"\tCODE:\n",
51			"\tRETVAL = $class\::$name ($args);\n",
52			"\tOUTPUT:\n",
53			"\tRETVAL\n";
54			} else {
55			print "$rettype\n$name ($params)\n",
56			"\tCODE:\n",
57			"\t$class\::$name ($args);\n",
58			}
59			} else {
60			print "$rettype\n$class\::$name ($params)\n";
61			}
62
63			print "\n";
64			}
65
66	root	1.3	if (@scalar_member) {
67			print "SV $scalar_member[0][1] ($class self, SV *newval = 0)\n";
68			print "\tPROTOTYPE: \$;\$\n";
69
70			if (@scalar_member > 1) {
71			print "\tALIAS:\n";
72			for (1 .. $#scalar_member) {
73	root	1.8	print "\t\t" . (c2perl $scalar_member[$_][1]) . "\t= $_\n";
74	root	1.3	}
75			}
76	root	1.1
77	root	1.3	print "\tCODE:\n";
78
79			# read
80			print "\tif (GIMME_V == G_VOID)\n",
81			"\t RETVAL = &PL_sv_undef;\n",
82			"\telse\n",
83			"\t switch (ix)\n",
84			"\t {\n",
85			(map "\t case $_: RETVAL = to_sv (self->$scalar_member[$_][1]); break;\n",
86			0 .. $#scalar_member),
87			"\t default: croak (\"scalar_member is write-only\");\n",
88			"\t };\n";
89	root	1.1
90	root	1.3	# write
91			print "\tif (newval)\n",
92			"\t switch (ix)\n",
93			"\t {\n",
94			(map "\t case $_: sv_to (newval, self->$scalar_member[$_][1]); break;\n",
95			grep $scalar_member[$_][0] eq "W",
96			0 .. $#scalar_member),
97			"\t default: croak (\"scalar_member is read-only\");\n",
98			"\t };\n";
99
100			print "\tOUTPUT: RETVAL\n\n";
101			}
102
103			if (@array_member) {
104			print "SV $array_member[0][1] ($class self, int idx, SV *newval = 0)\n";
105			print "\tPROTOTYPE: \$;\$\n";
106
107			if (@array_member > 1) {
108			print "\tALIAS:\n";
109			for (1 .. $#array_member) {
110	root	1.8	print "\t\t" . (c2perl $array_member[$_][1]) . "\t= $_\n";
111	root	1.3	}
112	root	1.1	}
113
114	root	1.3	print "\tCODE:\n";
115
116			print "\tif (idx < 0) croak (\"negative array index\");\n";
117
118			# range
119			print "\t switch (ix)\n",
120			"\t {\n",
121			(map "\t case $_: if (idx >= $array_member[$_][2]) croak (\"array index out of bounds\"); break;\n",
122			0 .. $#array_member),
123			"\t };\n";
124	root	1.1
125			# read
126	root	1.3	print "\tif (GIMME_V == G_VOID)\n",
127			"\t RETVAL = &PL_sv_undef;\n",
128			"\telse\n",
129			"\t switch (ix)\n",
130			"\t {\n",
131			(map "\t case $_: RETVAL = to_sv (self->$array_member[$_][1] [idx]); break;\n",
132			0 .. $#array_member),
133			"\t default: croak (\"array_member is write-only\");\n",
134			"\t };\n";
135	root	1.1
136			# write
137	root	1.3	print "\tif (newval)\n",
138			"\t switch (ix)\n",
139			"\t {\n",
140			(map "\t case $_: sv_to (newval, self->$array_member[$_][1] [idx]); break;\n",
141			grep $array_member[$_][0] eq "W",
142			0 .. $#array_member),
143			"\t default: croak (\"array_member is read-only\");\n",
144			"\t };\n";
145	root	1.1
146	root	1.3	print "\tOUTPUT: RETVAL\n\n";
147			}
148	root	1.1