cpan/Win32API-File/const2perl.h

   1 /* const2perl.h -- For converting C constants into Perl constant subs\r
   2  *      (usually via XS code but can just write Perl code to stdout). */\r
   3 \r
   4 \r
   5 /* #ifndef _INCLUDE_CONST2PERL_H\r
   6  * #define _INCLUDE_CONST2PERL_H 1 */\r
   7 \r
   8 #ifndef CONST2WRITE_PERL        /* Default is "const to .xs": */\r
   9 \r
  10 # define newconst( sName, sFmt, xValue, newSV ) \\r
  11                 newCONSTSUB( mHvStash, sName, newSV )\r
  12 \r
  13 # define noconst( const )       av_push( mAvExportFail, newSVpv(#const,0) )\r
  14 \r
  15 # define setuv(u)       do {                            \\r
  16         mpSvNew= newSViv(0); sv_setuv(mpSvNew,u);       \\r
  17     } while( 0 )\r
  18 \r
  19 #else\r
  20 \r
  21 /* #ifdef __cplusplus\r
  22  * # undef printf\r
  23  * # undef fprintf\r
  24  * # undef stderr\r
  25  * # define stderr (&_iob[2])\r
  26  * # undef iobuf\r
  27  * # undef malloc\r
  28  * #endif */\r
  29 \r
  30 # include <stdio.h>     /* Probably already included, but shouldn't hurt */\r
  31 # include <errno.h>     /* Possibly already included, but shouldn't hurt */\r
  32 \r
  33 # define newconst( sName, sFmt, xValue, newSV ) \\r
  34                 printf( "sub %s () { " sFmt " }\n", sName, xValue )\r
  35 \r
  36 # define noconst( const )       printf( "push @EXPORT_FAIL, '%s';\n", #const )\r
  37 \r
  38 # define setuv(u)       /* Nothing */\r
  39 \r
  40 # ifndef IVdf\r
  41 #  define IVdf "ld"\r
  42 # endif\r
  43 # ifndef UVuf\r
  44 #  define UVuf "lu"\r
  45 # endif\r
  46 # ifndef UVxf\r
  47 #  define UVxf "lX"\r
  48 # endif\r
  49 # ifndef NV_DIG\r
  50 #  define NV_DIG 15\r
  51 # endif\r
  52 \r
  53 static char *\r
  54 escquote( const char *sValue )\r
  55 {\r
  56     Size_t lLen= 1+2*strlen(sValue);\r
  57     char *sEscaped= (char *) malloc( lLen );\r
  58     char *sNext= sEscaped;\r
  59     if(  NULL == sEscaped  ) {\r
  60         fprintf( stderr, "Can't allocate %"UVuf"-byte buffer (errno=%d)\n",\r
  61           U_V(lLen), _errno );\r
  62         exit( 1 );\r
  63     }\r
  64     while(  '\0' != *sValue  ) {\r
  65         switch(  *sValue  ) {\r
  66          case '\'':\r
  67          case '\\':\r
  68             *(sNext++)= '\\';\r
  69         }\r
  70         *(sNext++)= *(sValue++);\r
  71     }\r
  72     *sNext= *sValue;\r
  73     return( sEscaped );\r
  74 }\r
  75 \r
  76 #endif\r
  77 \r
  78 \r
  79 #ifdef __cplusplus\r
  80 \r
  81 class _const2perl {\r
  82  public:\r
  83     char msBuf[64];     /* Must fit sprintf of longest NV */\r
  84 #ifndef CONST2WRITE_PERL\r
  85     HV *mHvStash;\r
  86     AV *mAvExportFail;\r
  87     SV *mpSvNew;\r
  88     _const2perl::_const2perl( char *sModName ) {\r
  89         mHvStash= gv_stashpv( sModName, TRUE );\r
  90         SV **pSv= hv_fetch( mHvStash, "EXPORT_FAIL", 11, TRUE );\r
  91         GV *gv;\r
  92         char *sVarName= (char *) malloc( 15+strlen(sModName) );\r
  93         strcpy( sVarName, sModName );\r
  94         strcat( sVarName, "::EXPORT_FAIL" );\r
  95         gv= gv_fetchpv( sVarName, 1, SVt_PVAV );\r
  96         mAvExportFail= GvAVn( gv );\r
  97     }\r
  98 #else\r
  99     _const2perl::_const2perl( char *sModName ) {\r
 100         ;       /* Nothing to do */\r
 101     }\r
 102 #endif /* CONST2WRITE_PERL */\r
 103     void mkconst( char *sName, unsigned long uValue ) {\r
 104         setuv(uValue);\r
 105         newconst( sName, "0x%"UVxf, uValue, mpSvNew );\r
 106     }\r
 107     void mkconst( char *sName, unsigned int uValue ) {\r
 108         setuv(uValue);\r
 109         newconst( sName, "0x%"UVxf, uValue, mpSvNew );\r
 110     }\r
 111     void mkconst( char *sName, unsigned short uValue ) {\r
 112         setuv(uValue);\r
 113         newconst( sName, "0x%"UVxf, uValue, mpSvNew );\r
 114     }\r
 115     void mkconst( char *sName, long iValue ) {\r
 116         newconst( sName, "%"IVdf, iValue, newSViv(iValue) );\r
 117     }\r
 118     void mkconst( char *sName, int iValue ) {\r
 119         newconst( sName, "%"IVdf, iValue, newSViv(iValue) );\r
 120     }\r
 121     void mkconst( char *sName, short iValue ) {\r
 122         newconst( sName, "%"IVdf, iValue, newSViv(iValue) );\r
 123     }\r
 124     void mkconst( char *sName, double nValue ) {\r
 125         newconst( sName, "%s",\r
 126           Gconvert(nValue,NV_DIG,0,msBuf), newSVnv(nValue) );\r
 127     }\r
 128     void mkconst( char *sName, char *sValue ) {\r
 129         newconst( sName, "'%s'", escquote(sValue), newSVpv(sValue,0) );\r
 130     }\r
 131     void mkconst( char *sName, const void *pValue ) {\r
 132         setuv((UV)pValue);\r
 133         newconst( sName, "0x%"UVxf, (UV)(pValue), mpSvNew );\r
 134     }\r
 135 /*#ifdef HAS_QUAD\r
 136  * HAS_QUAD only means pack/unpack deal with them, not that SVs can.\r
 137  *    void mkconst( char *sName, Quad_t *qValue ) {\r
 138  *      newconst( sName, "0x%"QVxf, qValue, newSVqv(qValue) );\r
 139  *    }\r
 140  *#endif / * HAS_QUAD */\r
 141 };\r
 142 \r
 143 #define START_CONSTS( sModName )        _const2perl const2( sModName );\r
 144 #define const2perl( const )             const2.mkconst( #const, const )\r
 145 \r
 146 #else   /* __cplusplus */\r
 147 \r
 148 # ifndef CONST2WRITE_PERL\r
 149 #  define START_CONSTS( sModName )                                      \\r
 150             HV *mHvStash= gv_stashpv( sModName, TRUE );                 \\r
 151             AV *mAvExportFail;                                          \\r
 152             SV *mpSvNew;                                                \\r
 153             { char *sVarName= malloc( 15+strlen(sModName) );            \\r
 154               GV *gv;                                                   \\r
 155                 strcpy( sVarName, sModName );                           \\r
 156                 strcat( sVarName, "::EXPORT_FAIL" );                    \\r
 157                 gv= gv_fetchpv( sVarName, 1, SVt_PVAV );                \\r
 158                 mAvExportFail= GvAVn( gv );                             \\r
 159             }\r
 160 # else\r
 161 #  define START_CONSTS( sModName )      /* Nothing */\r
 162 # endif\r
 163 \r
 164 #define const2perl( const )     do {                                    \\r
 165         if(  const < 0  ) {                                             \\r
 166             newconst( #const, "%"IVdf, const, newSViv((IV)const) );     \\r
 167         } else {                                                        \\r
 168             setuv( (UV)const );                                         \\r
 169             newconst( #const, "0x%"UVxf, const, mpSvNew );              \\r
 170         }                                                               \\r
 171     } while( 0 )\r
 172 \r
 173 #endif  /* __cplusplus */\r
 174 \r
 175 \r
 176 //Example use:\r
 177 //#include <const2perl.h>\r
 178 //  {\r
 179 //    START_CONSTS( "Package::Name" )   /* No ";" */\r
 180 //#ifdef $const\r
 181 //    const2perl( $const );\r
 182 //#else\r
 183 //    noconst( $const );\r
 184 //#endif\r
 185 //  }\r
 186 // sub ? { my( $sConstName )= @_;\r
 187 //    return $sConstName;       # "#ifdef $sConstName"\r
 188 //    return FALSE;             # Same as above\r
 189 //    return "HAS_QUAD";        # "#ifdef HAS_QUAD"\r
 190 //    return "#if 5.04 <= VERSION";\r
 191 //    return "#if 0";\r
 192 //    return 1;         # No #ifdef\r
 193 /* #endif / * _INCLUDE_CONST2PERL_H */\r