Commit | Line | Data |
00701878 |
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 */ |