cpan/Win32API-File/const2perl.h

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