xref: /openbsd-src/gnu/usr.bin/perl/cpan/Win32API-File/const2perl.h (revision b8851fcc53cbe24fd20b090f26dd149e353f6174)

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