| /* const2perl.h -- For converting C constants into Perl constant subs |
| * (usually via XS code but can just write Perl code to stdout). */ |
| |
| |
| /* #ifndef _INCLUDE_CONST2PERL_H |
| * #define _INCLUDE_CONST2PERL_H 1 */ |
| |
| #ifndef CONST2WRITE_PERL /* Default is "const to .xs": */ |
| |
| # define newconst( sName, sFmt, xValue, newSV ) \ |
| newCONSTSUB( mHvStash, sName, newSV ) |
| |
| # define noconst( const ) av_push( mAvExportFail, newSVpv(#const,0) ) |
| |
| # define setuv(u) do { \ |
| mpSvNew= newSViv(0); sv_setuv(mpSvNew,u); \ |
| } while( 0 ) |
| |
| #else |
| |
| /* #ifdef __cplusplus |
| * # undef printf |
| * # undef fprintf |
| * # undef stderr |
| * # define stderr (&_iob[2]) |
| * # undef iobuf |
| * # undef malloc |
| * #endif */ |
| |
| # include <stdio.h> /* Probably already included, but shouldn't hurt */ |
| # include <errno.h> /* Possibly already included, but shouldn't hurt */ |
| |
| # define newconst( sName, sFmt, xValue, newSV ) \ |
| printf( "sub %s () { " sFmt " }\n", sName, xValue ) |
| |
| # define noconst( const ) printf( "push @EXPORT_FAIL, '%s';\n", #const ) |
| |
| # define setuv(u) /* Nothing */ |
| |
| # ifndef IVdf |
| # define IVdf "ld" |
| # endif |
| # ifndef UVuf |
| # define UVuf "lu" |
| # endif |
| # ifndef UVxf |
| # define UVxf "lX" |
| # endif |
| # ifndef NV_DIG |
| # define NV_DIG 15 |
| # endif |
| |
| static char * |
| escquote( const char *sValue ) |
| { |
| Size_t lLen= 1+2*strlen(sValue); |
| char *sEscaped= (char *) malloc( lLen ); |
| char *sNext= sEscaped; |
| if( NULL == sEscaped ) { |
| fprintf( stderr, "Can't allocate %"UVuf"-byte buffer (errno=%d)\n", |
| U_V(lLen), _errno ); |
| exit( 1 ); |
| } |
| while( '\0' != *sValue ) { |
| switch( *sValue ) { |
| case '\'': |
| case '\\': |
| *(sNext++)= '\\'; |
| } |
| *(sNext++)= *(sValue++); |
| } |
| *sNext= *sValue; |
| return( sEscaped ); |
| } |
| |
| #endif |
| |
| |
| #ifdef __cplusplus |
| |
| class _const2perl { |
| public: |
| char msBuf[64]; /* Must fit sprintf of longest NV */ |
| #ifndef CONST2WRITE_PERL |
| HV *mHvStash; |
| AV *mAvExportFail; |
| SV *mpSvNew; |
| _const2perl::_const2perl( char *sModName ) { |
| mHvStash= gv_stashpv( sModName, TRUE ); |
| SV **pSv= hv_fetch( mHvStash, "EXPORT_FAIL", 11, TRUE ); |
| GV *gv; |
| char *sVarName= (char *) malloc( 15+strlen(sModName) ); |
| strcpy( sVarName, sModName ); |
| strcat( sVarName, "::EXPORT_FAIL" ); |
| gv= gv_fetchpv( sVarName, 1, SVt_PVAV ); |
| mAvExportFail= GvAVn( gv ); |
| } |
| #else |
| _const2perl::_const2perl( char *sModName ) { |
| ; /* Nothing to do */ |
| } |
| #endif /* CONST2WRITE_PERL */ |
| void mkconst( char *sName, unsigned long uValue ) { |
| setuv(uValue); |
| newconst( sName, "0x%"UVxf, uValue, mpSvNew ); |
| } |
| void mkconst( char *sName, unsigned int uValue ) { |
| setuv(uValue); |
| newconst( sName, "0x%"UVxf, uValue, mpSvNew ); |
| } |
| void mkconst( char *sName, unsigned short uValue ) { |
| setuv(uValue); |
| newconst( sName, "0x%"UVxf, uValue, mpSvNew ); |
| } |
| void mkconst( char *sName, long iValue ) { |
| newconst( sName, "%"IVdf, iValue, newSViv(iValue) ); |
| } |
| void mkconst( char *sName, int iValue ) { |
| newconst( sName, "%"IVdf, iValue, newSViv(iValue) ); |
| } |
| void mkconst( char *sName, short iValue ) { |
| newconst( sName, "%"IVdf, iValue, newSViv(iValue) ); |
| } |
| void mkconst( char *sName, double nValue ) { |
| newconst( sName, "%s", |
| Gconvert(nValue,NV_DIG,0,msBuf), newSVnv(nValue) ); |
| } |
| void mkconst( char *sName, char *sValue ) { |
| newconst( sName, "'%s'", escquote(sValue), newSVpv(sValue,0) ); |
| } |
| void mkconst( char *sName, const void *pValue ) { |
| setuv((UV)pValue); |
| newconst( sName, "0x%"UVxf, (UV)(pValue), mpSvNew ); |
| } |
| /*#ifdef HAS_QUAD |
| * HAS_QUAD only means pack/unpack deal with them, not that SVs can. |
| * void mkconst( char *sName, Quad_t *qValue ) { |
| * newconst( sName, "0x%"QVxf, qValue, newSVqv(qValue) ); |
| * } |
| *#endif / * HAS_QUAD */ |
| }; |
| |
| #define START_CONSTS( sModName ) _const2perl const2( sModName ); |
| #define const2perl( const ) const2.mkconst( #const, const ) |
| |
| #else /* __cplusplus */ |
| |
| # ifndef CONST2WRITE_PERL |
| # define START_CONSTS( sModName ) \ |
| HV *mHvStash= gv_stashpv( sModName, TRUE ); \ |
| AV *mAvExportFail; \ |
| SV *mpSvNew; \ |
| { char *sVarName= malloc( 15+strlen(sModName) ); \ |
| GV *gv; \ |
| strcpy( sVarName, sModName ); \ |
| strcat( sVarName, "::EXPORT_FAIL" ); \ |
| gv= gv_fetchpv( sVarName, 1, SVt_PVAV ); \ |
| mAvExportFail= GvAVn( gv ); \ |
| } |
| # else |
| # define START_CONSTS( sModName ) /* Nothing */ |
| # endif |
| |
| #define const2perl( const ) do { \ |
| if( const < 0 ) { \ |
| newconst( #const, "%"IVdf, const, newSViv((IV)const) ); \ |
| } else { \ |
| setuv( (UV)const ); \ |
| newconst( #const, "0x%"UVxf, const, mpSvNew ); \ |
| } \ |
| } while( 0 ) |
| |
| #endif /* __cplusplus */ |
| |
| |
| //Example use: |
| //#include <const2perl.h> |
| // { |
| // START_CONSTS( "Package::Name" ) /* No ";" */ |
| //#ifdef $const |
| // const2perl( $const ); |
| //#else |
| // noconst( $const ); |
| //#endif |
| // } |
| // sub ? { my( $sConstName )= @_; |
| // return $sConstName; # "#ifdef $sConstName" |
| // return FALSE; # Same as above |
| // return "HAS_QUAD"; # "#ifdef HAS_QUAD" |
| // return "#if 5.04 <= VERSION"; |
| // return "#if 0"; |
| // return 1; # No #ifdef |
| /* #endif / * _INCLUDE_CONST2PERL_H */ |