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 *
escquote(const char * sValue)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;
_const2perl(char * sModName)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
_const2perl(char * sModName)99 _const2perl::_const2perl( char *sModName ) {
100 ; /* Nothing to do */
101 }
102 #endif /* CONST2WRITE_PERL */
mkconst(char * sName,unsigned long uValue)103 void mkconst( char *sName, unsigned long uValue ) {
104 setuv(uValue);
105 newconst( sName, "0x%"UVxf, uValue, mpSvNew );
106 }
mkconst(char * sName,unsigned int uValue)107 void mkconst( char *sName, unsigned int uValue ) {
108 setuv(uValue);
109 newconst( sName, "0x%"UVxf, uValue, mpSvNew );
110 }
mkconst(char * sName,unsigned short uValue)111 void mkconst( char *sName, unsigned short uValue ) {
112 setuv(uValue);
113 newconst( sName, "0x%"UVxf, uValue, mpSvNew );
114 }
mkconst(char * sName,long iValue)115 void mkconst( char *sName, long iValue ) {
116 newconst( sName, "%"IVdf, iValue, newSViv(iValue) );
117 }
mkconst(char * sName,int iValue)118 void mkconst( char *sName, int iValue ) {
119 newconst( sName, "%"IVdf, iValue, newSViv(iValue) );
120 }
mkconst(char * sName,short iValue)121 void mkconst( char *sName, short iValue ) {
122 newconst( sName, "%"IVdf, iValue, newSViv(iValue) );
123 }
mkconst(char * sName,double nValue)124 void mkconst( char *sName, double nValue ) {
125 newconst( sName, "%s",
126 Gconvert(nValue,NV_DIG,0,msBuf), newSVnv(nValue) );
127 }
mkconst(char * sName,char * sValue)128 void mkconst( char *sName, char *sValue ) {
129 newconst( sName, "'%s'", escquote(sValue), newSVpv(sValue,0) );
130 }
mkconst(char * sName,const void * pValue)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 */
194