Perl and XS: Example 3: Set::Bit

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"
typedef struct
{
    /* The range of the set is 0..n_bits - 1 */
    int n_bits;
    /* The number of bytes used for storage. */
    int n_chars;
    /* The bytes used for storage. */
    unsigned char * chars;
}vector;

typedef vector* Set__Bit;

vector * new (pTHX_ int n_bits)
{
    vector * p;
    Newx(p,1,vector);
    if (!p) {
	croak ("Out of memory");
    }
    p->n_bits = n_bits;

    /* We use one char to store the bits. The C standard promises that
       one byte contains at least eight bits. */

    p->n_chars = (n_bits + 8 - 1) / 8;
	Newxz(p->chars, p->n_chars, unsigned char);

    if (!p->chars) {
	croak ("Out of memory");
    }
    return p;
}

/* Set bit "n" in "p". */

void insert (vector *p, int n)
{
    int q;
    int r;

    if (n < 0 || n >= p->n_bits) {
	croak ("Bit out of range");
    }

    q = n / 8;
    r = n % 8;

    p->chars[q] |= 1 << r;
}

void DESTROY (vector *p)
{
    //printf("good\n");
    Safefree(p->chars);
    Safefree(p);
}


MODULE = Set::Bit		PACKAGE = Set::Bit		

Set::Bit
new(package, nBits)
        char *package
        int   nBits
        CODE:
        RETVAL = new(aTHX_ nBits);
        OUTPUT:
        RETVAL
        
void
insert(pVector, n)
        Set::Bit pVector
        int      n


void
DESTROY(pVector)
        Set::Bit pVector

 

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"
typedef struct
{
    /* The range of the set is 0..n_bits - 1 */
    int n_bits;
    /* The number of bytes used for storage. */
    int n_chars;
    /* The bytes used for storage. */
    unsigned char * chars;
}vector;

typedef vector* Set__Bit;

vector * new (pTHX_ int n_bits)
{
    vector * p;
    Newx(p,1,vector);
    if (!p) {
	croak ("Out of memory");
    }
    p->n_bits = n_bits;

    /* We use one char to store the bits. The C standard promises that
       one byte contains at least eight bits. */

    p->n_chars = (n_bits + 8 - 1) / 8;
	Newxz(p->chars, p->n_chars, unsigned char);

    if (!p->chars) {
	croak ("Out of memory");
    }
    return p;
}

/* Set bit "n" in "p". */

void insert (vector *p, int n)
{
    int q;
    int r;

    if (n < 0 || n >= p->n_bits) {
	croak ("Bit out of range");
    }

    q = n / 8;
    r = n % 8;

    p->chars[q] |= 1 << r;
}

void DESTROY (vector *p)
{
    printf("good luck\n");
    Safefree(p->chars);
    Safefree(p);
}
        
XS(XS_Set__Bit_new)
{
    dXSARGS;
    if (items != 2)
        croak("Usage: Set::Bit::new(package,nBits)");
    {
        int     	 nBits = (int)SvIV(ST(1));
        Set__Bit 	RETVAL;

        RETVAL = new(aTHX_ nBits);
        ST(0) = sv_newmortal();
        sv_setref_pv(ST(0), "Set::Bit", (void*)RETVAL);
    }
    XSRETURN(1);
}

XS(XS_Set__Bit_insert)
{
    dXSARGS;
    if (items != 2)
        croak("Usage: Set::Bit::insert(pVector, n)");
    {
        Set__Bit	pVector;
        int     	n = (int)SvIV(ST(1));

        if (SvROK(ST(0)) && sv_derived_from(ST(0), "Set::Bit")) {
            pVector = (Set__Bit) SvIV((SV*)SvRV(ST(0)));
        }
        else
            croak("pVector is not of type Set::Bit");

        insert(pVector, n);
    }
    XSRETURN_EMPTY;
}

XS(XS_Set__Bit_DESTROY)
{
    dXSARGS;
    Set__Bit	pVector;
    if (items != 1)
    {
		XSRETURN_EMPTY;
    }

	if (SvROK(ST(0))) {
		IV tmp = SvIV((SV*)SvRV(ST(0)));
		pVector = INT2PTR(Set__Bit,tmp);
	}
	else
		croak(aTHX_ "%s: %s is not a reference",
			"Set::Bit::DESTROY",
			"pVector");

	DESTROY(pVector);
    XSRETURN_EMPTY;
}

XS_EXTERNAL(boot_Set__Bit)
{
    dXSARGS;
    const char* file = __FILE__;

    newXS("Set::Bit::new", XS_Set__Bit_new, file);
    newXS("Set::Bit::insert", XS_Set__Bit_insert, file);
    newXS("Set::Bit::DESTROY", XS_Set__Bit_DESTROY, file);
	if (PL_unitcheckav)
		call_list(PL_scopestack_ix, PL_unitcheckav);
    XSRETURN_YES;
}

A Perl object

Earlier, I said that I wanted the Set::Bit object to be the C-languagevector struct, rather than a Perl data object. It didn't work out that way. TheSet::Bit object is indeed a Perl data object: it is the scalar created bysv_setref_pv().

The Set::Bit object gives the essential features of a C-language object. Data is represented in C, we can write methods in C, and methods written in C access instance data through avector *, passed as the first argument. At the same time, the Set::Bit object gives us the flexibility to write methods in Perl.

SV = IV(0x1d710a8) at 0x1d710ac
  REFCNT = 1
  FLAGS = (ROK)
  RV = 0x546f14
  SV = PVMG(0x1d67e84) at 0x546f14
    REFCNT = 1
    FLAGS = (OBJECT,IOK,pIOK)
    IV = 30824164                        // 指针p的值
    NV = 0
    PV = 0
    STASH = 0x1d7119c   "Set::Bit"

上面的SV dump是new方法后的结果，在perl空间中也可以实现相同的效果，比如：

use Devel::Peek;
{
	local $m=30824164;
	$r = \$m;
	bless $r,"Devel::Peek";
	
}
Dump ($r);

首先，创建一个临时的SViv，iv值为指针值（对象指针）

然后，创建一个RV，并指向之前的这个SV，并在Devel::Peek模块下bless RV

最后，返回RV。

输出:

SV = IV(0x6370b4) at 0x6370b4
  REFCNT = 1
  FLAGS = (ROK)
  RV = 0x4db35c
  SV = PVMG(0x628dd4) at 0x4db35c
    REFCNT = 1
    FLAGS = (OBJECT,IOK,pIOK)
    IV = 30824164
    NV = 0
    PV = 0
    STASH = 0x63733c    "Devel::Peek"