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 */ 194