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
53static char *
54escquote( 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
81class _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