diff options
Diffstat (limited to 'win32/ext/Win32API/File/const2perl.h')
| -rw-r--r-- | win32/ext/Win32API/File/const2perl.h | 193 |
1 files changed, 193 insertions, 0 deletions
diff --git a/win32/ext/Win32API/File/const2perl.h b/win32/ext/Win32API/File/const2perl.h new file mode 100644 index 0000000000..dbd94c10a8 --- /dev/null +++ b/win32/ext/Win32API/File/const2perl.h @@ -0,0 +1,193 @@ +/* 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 */ |