Commit | Line | Data |
---|---|---|
00701878 SH |
1 | /* const2perl.h -- For converting C constants into Perl constant subs |
2 | * (usually via XS code but can just write Perl code to stdout). */ | |
3 | ||
4 | ||
5 | /* #ifndef _INCLUDE_CONST2PERL_H | |
6 | * #define _INCLUDE_CONST2PERL_H 1 */ | |
7 | ||
8 | #ifndef CONST2WRITE_PERL /* Default is "const to .xs": */ | |
9 | ||
10 | # define newconst( sName, sFmt, xValue, newSV ) \ | |
11 | newCONSTSUB( mHvStash, sName, newSV ) | |
12 | ||
13 | # define noconst( const ) av_push( mAvExportFail, newSVpv(#const,0) ) | |
14 | ||
15 | # define setuv(u) do { \ | |
16 | mpSvNew= newSViv(0); sv_setuv(mpSvNew,u); \ | |
17 | } while( 0 ) | |
18 | ||
19 | #else | |
20 | ||
21 | /* #ifdef __cplusplus | |
22 | * # undef printf | |
23 | * # undef fprintf | |
24 | * # undef stderr | |
25 | * # define stderr (&_iob[2]) | |
26 | * # undef iobuf | |
27 | * # undef malloc | |
28 | * #endif */ | |
29 | ||
30 | # include <stdio.h> /* Probably already included, but shouldn't hurt */ | |
31 | # include <errno.h> /* Possibly already included, but shouldn't hurt */ | |
32 | ||
33 | # define newconst( sName, sFmt, xValue, newSV ) \ | |
34 | printf( "sub %s () { " sFmt " }\n", sName, xValue ) | |
35 | ||
36 | # define noconst( const ) printf( "push @EXPORT_FAIL, '%s';\n", #const ) | |
37 | ||
38 | # define setuv(u) /* Nothing */ | |
39 | ||
40 | # ifndef IVdf | |
41 | # define IVdf "ld" | |
42 | # endif | |
43 | # ifndef UVuf | |
44 | # define UVuf "lu" | |
45 | # endif | |
46 | # ifndef UVxf | |
47 | # define UVxf "lX" | |
48 | # endif | |
49 | # ifndef NV_DIG | |
50 | # define NV_DIG 15 | |
51 | # endif | |
52 | ||
53 | static char * | |
54 | escquote( const char *sValue ) | |
55 | { | |
56 | Size_t lLen= 1+2*strlen(sValue); | |
57 | char *sEscaped= (char *) malloc( lLen ); | |
58 | char *sNext= sEscaped; | |
59 | if( NULL == sEscaped ) { | |
60 | fprintf( stderr, "Can't allocate %"UVuf"-byte buffer (errno=%d)\n", | |
61 | U_V(lLen), _errno ); | |
62 | exit( 1 ); | |
63 | } | |
64 | while( '\0' != *sValue ) { | |
65 | switch( *sValue ) { | |
66 | case '\'': | |
67 | case '\\': | |
68 | *(sNext++)= '\\'; | |
69 | } | |
70 | *(sNext++)= *(sValue++); | |
71 | } | |
72 | *sNext= *sValue; | |
73 | return( sEscaped ); | |
74 | } | |
75 | ||
76 | #endif | |
77 | ||
78 | ||
79 | #ifdef __cplusplus | |
80 | ||
81 | class _const2perl { | |
82 | public: | |
83 | char msBuf[64]; /* Must fit sprintf of longest NV */ | |
84 | #ifndef CONST2WRITE_PERL | |
85 | HV *mHvStash; | |
86 | AV *mAvExportFail; | |
87 | SV *mpSvNew; | |
88 | _const2perl::_const2perl( char *sModName ) { | |
89 | mHvStash= gv_stashpv( sModName, TRUE ); | |
90 | SV **pSv= hv_fetch( mHvStash, "EXPORT_FAIL", 11, TRUE ); | |
91 | GV *gv; | |
92 | char *sVarName= (char *) malloc( 15+strlen(sModName) ); | |
93 | strcpy( sVarName, sModName ); | |
94 | strcat( sVarName, "::EXPORT_FAIL" ); | |
95 | gv= gv_fetchpv( sVarName, 1, SVt_PVAV ); | |
96 | mAvExportFail= GvAVn( gv ); | |
97 | } | |
98 | #else | |
99 | _const2perl::_const2perl( char *sModName ) { | |
100 | ; /* Nothing to do */ | |
101 | } | |
102 | #endif /* CONST2WRITE_PERL */ | |
103 | void mkconst( char *sName, unsigned long uValue ) { | |
104 | setuv(uValue); | |
105 | newconst( sName, "0x%"UVxf, uValue, mpSvNew ); | |
106 | } | |
107 | void mkconst( char *sName, unsigned int uValue ) { | |
108 | setuv(uValue); | |
109 | newconst( sName, "0x%"UVxf, uValue, mpSvNew ); | |
110 | } | |
111 | void mkconst( char *sName, unsigned short uValue ) { | |
112 | setuv(uValue); | |
113 | newconst( sName, "0x%"UVxf, uValue, mpSvNew ); | |
114 | } | |
115 | void mkconst( char *sName, long iValue ) { | |
116 | newconst( sName, "%"IVdf, iValue, newSViv(iValue) ); | |
117 | } | |
118 | void mkconst( char *sName, int iValue ) { | |
119 | newconst( sName, "%"IVdf, iValue, newSViv(iValue) ); | |
120 | } | |
121 | void mkconst( char *sName, short iValue ) { | |
122 | newconst( sName, "%"IVdf, iValue, newSViv(iValue) ); | |
123 | } | |
124 | void mkconst( char *sName, double nValue ) { | |
125 | newconst( sName, "%s", | |
126 | Gconvert(nValue,NV_DIG,0,msBuf), newSVnv(nValue) ); | |
127 | } | |
128 | void mkconst( char *sName, char *sValue ) { | |
129 | newconst( sName, "'%s'", escquote(sValue), newSVpv(sValue,0) ); | |
130 | } | |
131 | void mkconst( char *sName, const void *pValue ) { | |
132 | setuv((UV)pValue); | |
133 | newconst( sName, "0x%"UVxf, (UV)(pValue), mpSvNew ); | |
134 | } | |
135 | /*#ifdef HAS_QUAD | |
136 | * HAS_QUAD only means pack/unpack deal with them, not that SVs can. | |
137 | * void mkconst( char *sName, Quad_t *qValue ) { | |
138 | * newconst( sName, "0x%"QVxf, qValue, newSVqv(qValue) ); | |
139 | * } | |
140 | *#endif / * HAS_QUAD */ | |
141 | }; | |
142 | ||
143 | #define START_CONSTS( sModName ) _const2perl const2( sModName ); | |
144 | #define const2perl( const ) const2.mkconst( #const, const ) | |
145 | ||
146 | #else /* __cplusplus */ | |
147 | ||
148 | # ifndef CONST2WRITE_PERL | |
149 | # define START_CONSTS( sModName ) \ | |
150 | HV *mHvStash= gv_stashpv( sModName, TRUE ); \ | |
151 | AV *mAvExportFail; \ | |
152 | SV *mpSvNew; \ | |
153 | { char *sVarName= malloc( 15+strlen(sModName) ); \ | |
154 | GV *gv; \ | |
155 | strcpy( sVarName, sModName ); \ | |
156 | strcat( sVarName, "::EXPORT_FAIL" ); \ | |
157 | gv= gv_fetchpv( sVarName, 1, SVt_PVAV ); \ | |
158 | mAvExportFail= GvAVn( gv ); \ | |
159 | } | |
160 | # else | |
161 | # define START_CONSTS( sModName ) /* Nothing */ | |
162 | # endif | |
163 | ||
164 | #define const2perl( const ) do { \ | |
165 | if( const < 0 ) { \ | |
166 | newconst( #const, "%"IVdf, const, newSViv((IV)const) ); \ | |
167 | } else { \ | |
168 | setuv( (UV)const ); \ | |
169 | newconst( #const, "0x%"UVxf, const, mpSvNew ); \ | |
170 | } \ | |
171 | } while( 0 ) | |
172 | ||
173 | #endif /* __cplusplus */ | |
174 | ||
175 | ||
176 | //Example use: | |
177 | //#include <const2perl.h> | |
178 | // { | |
179 | // START_CONSTS( "Package::Name" ) /* No ";" */ | |
180 | //#ifdef $const | |
181 | // const2perl( $const ); | |
182 | //#else | |
183 | // noconst( $const ); | |
184 | //#endif | |
185 | // } | |
186 | // sub ? { my( $sConstName )= @_; | |
187 | // return $sConstName; # "#ifdef $sConstName" | |
188 | // return FALSE; # Same as above | |
189 | // return "HAS_QUAD"; # "#ifdef HAS_QUAD" | |
190 | // return "#if 5.04 <= VERSION"; | |
191 | // return "#if 0"; | |
192 | // return 1; # No #ifdef | |
193 | /* #endif / * _INCLUDE_CONST2PERL_H */ |