1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
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 */
|
