This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 5
[perl5.git] / ext / xvarpp
CommitLineData
93a17b20
LW
1#!/usr/bin/perl
2# $Header$
3
4$usage = "Usage: tuv [-a] [-c] typemap file.uv\n";
5die $usage unless (@ARGV >= 2 && @ARGV <= 4);
6
7SWITCH: while ($ARGV[0] =~ /^-/) {
8 $flag = shift @ARGV;
9 $aflag = 1, next SWITCH if $flag =~ /^-a$/;
10 $cflag = 1, next SWITCH if $flag =~ /^-c$/;
11 die $usage;
12}
13
14$typemap = shift @ARGV;
15open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
16while (<TYPEMAP>) {
17 next if /^\s*$/ || /^#/;
18 chop;
19 ($typename, $kind) = split(/\t+/);
20 $type_kind{$typename} = $kind;
21}
22close(TYPEMAP);
23
24$uvfile = shift @ARGV;
25open(F, $uvfile) || die "cannot open $uvfile\n";
26#($uvoutfile = $uvfile) =~ s|^.*/([^/]*).us$|\1.c| ;
27#print "uvoutfile is $uvoutfile\n";
28
29#open(FOUT, ">$uvoutfile") || die "cannot open $uvoutfile\n";
30#select(FOUT);
31
32while (<F>) {
33 last if ($Module, $foo, $Package, $foo1, $Prefix) =
34 /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(\w+))?/;
35 print $_;
36}
463ee0b2 37$Package .= "::" if defined $Package && $Package ne "";
93a17b20
LW
38print <<EOF;
39static struct varinfo varinfo [] = {
40EOF
41
42while (<F>) {
43 next if /^s*$/ || /^#/;
44 if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(\w+))?/) {
45 $Module = $1;
46 $foo = $2;
47 $Package = $3;
48 $foo1 = $4;
49 $Prefix = $5;
50 $Package .= "'" if defined $Package && $Package ne "";
51 next;
52 }
53 chop;
54 $func = undef;
55 ($var, $kind, $store, $read) = split(/\t+/);
56 die "$kind not defined in typemap\n" if !defined($type_kind{$kind});
57 $flags = "0";
58 if ($store =~ /FUNC=(.*)/) {
59 $flags .= "|VI_FUNC";
60 $func = $1;
61 } elsif ($store eq "VAR") {
62 $flags .= "|VI_VARIABLE";
63 } elsif ($store ne "VAL") {
64 die "$var storage class not VAL, VAR or FUNC\n";
65 }
66 if ($read eq "READWRITE") {
67 $flags .= "|VI_READWRITE";
68 } elsif ($read ne "READONLY") {
69 die "$var access class not READONLY or READWRITE\n";
70 }
71 SIZE: {
72 $type_kind = $type_kind{$kind};
73 $size = 0;
74 do {$size = "sizeof(int)"; last SIZE; }
75 if ($type_kind eq "T_INT");
76 do {$size = "sizeof($kind)"; last SIZE; }
77 if ($type_kind eq "T_ENUM");
78 do {$size = "sizeof(unsigned int)"; last SIZE; }
79 if ($type_kind eq "T_U_INT");
80 do {$size = "sizeof(short)"; last SIZE; }
81 if ($type_kind eq "T_SHORT");
82 do {$size = "sizeof(unsigned short)"; last SIZE; }
83 if ($type_kind eq "T_U_SHORT");
84 do {$size = "sizeof(long)"; last SIZE; }
85 if ($type_kind eq "T_LONG");
86 do {$size = "sizeof(unsigned long)"; last SIZE; }
87 if ($type_kind eq "T_U_LONG");
88 do {$size = "sizeof(char)"; last SIZE; }
89 if ($type_kind eq "T_CHAR");
90 do {$size = "sizeof(unsigned char)"; last SIZE; }
91 if ($type_kind eq "T_U_CHAR");
92 do {$size = "0"; last SIZE; }
93 if ($type_kind eq "T_STRING");
94 do {$size = "sizeof(char *)"; last SIZE; }
95 if ($type_kind eq "T_PTR");
96 do {$size = "sizeof($kind)"; last SIZE; }
97 if ($type_kind eq "T_OPAQUE");
98 }
99 ($name = $var) =~ s/^$Prefix//;
100 print " { \"$Package$name\", $type_kind, $flags, $size, ";
101 if ($store =~ /FUNC/) {
102 print "(char *)$func, 0.0 },\n";
103 } elsif ($store eq "VAR") {
104 print "(char *)&$var, 0.0 },\n";
105 } elsif ($type_kind eq "T_FLOAT" || $type_kind eq "T_DOUBLE") {
106 print "0, $var },\n";
107 } else {
108 print "(char *)$var, 0.0 },\n";
109 }
110}
111print <<EOF if $aflag;
112};
113
114static unsigned long varinfolen = sizeof(varinfo)/sizeof(*varinfo);
115
463ee0b2 116static int UV_val(int ix, SV *sv)
93a17b20 117{
463ee0b2 118 return common_UV_val(varinfo, varinfolen, ix, sv);
93a17b20
LW
119}
120
463ee0b2 121static int UV_set(int ix, SV *sv)
93a17b20 122{
463ee0b2 123 return common_UV_set(varinfo, varinfolen, ix, sv);
93a17b20
LW
124}
125EOF
126print <<EOF if !$aflag;
127};
128
129static unsigned long varinfolen = sizeof(varinfo)/sizeof(*varinfo);
130
463ee0b2 131static int UV_val(ix, sv)
93a17b20 132int ix;
463ee0b2 133SV *sv;
93a17b20 134{
463ee0b2 135 return common_UV_val(varinfo, varinfolen, ix, sv);
93a17b20
LW
136}
137
463ee0b2 138static int UV_set(ix, sv)
93a17b20 139int ix;
463ee0b2 140SV *sv;
93a17b20 141{
463ee0b2 142 return common_UV_set(varinfo, varinfolen, ix, sv);
93a17b20
LW
143}
144
145EOF
146print qq/extern "C"\n/ if $cflag;
147print <<EOF;
148void init_$Module()
149{
150 int i;
151 struct ufuncs uf;
152
153 uf.uf_set = UV_set;
154 uf.uf_val = UV_val;
155 for (i = 0; i < varinfolen; i++) {
156 uf.uf_index = i;
157 magicname(varinfo[i].vname, (char *)&uf, sizeof uf);
158 }
159}
160
161EOF