new recibe como argumento CLASS la cadena de
caracteres que describe la clase (esto es, 'rectangular').
59 rectangular 60 new(CLASS) 61 char *CLASS = NO_INIT 62 PROTOTYPE: $ 63 CODE: 64 Zero((void*)&RETVAL, sizeof(RETVAL), char); 65 OUTPUT: 66 RETVALRecuerde que la llamada a
new tiene la forma:
my $r = rectangular->new();Puesto que
RETVAL es de tipo rectangular lo que esta haciendo
el código de la línea 64 es retornar un espacio contiguo de memoria
de tamaño el de struct rectangular iniciada
con ceros. En ese momento interviene el código OUTPUT
del typemap asociado con rectangular.
Para ello, h2xs ha generado un
fichero typemap con los siguientes contenidos:
lhp@nereida:~/projects/perl/src/XSUB/h2xsexample/Coord$ cat -n typemap
1 const char * T_PTROBJ
2 polar T_OPAQUE_STRUCT
3 polar * T_PTROBJ
4 rectangular T_OPAQUE_STRUCT
5 rectangular * T_PTROBJ
6 #############################################################################
7 INPUT
8 T_OPAQUE_STRUCT
9 if (sv_derived_from($arg, \"${ntype}\")) {
10 STRLEN len;
11 char *s = SvPV((SV*)SvRV($arg), len);
12
13 if (len != sizeof($var))
14 croak(\"Size %d of packed data != expected %d\",
15 len, sizeof($var));
16 $var = *($type *)s;
17 }
18 else
19 croak(\"$var is not of type ${ntype}\")
20 #############################################################################
21 OUTPUT
22 T_OPAQUE_STRUCT
23 sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
El valor retornado viene por tanto gobernado por la entrada de la línea
23. La llamada a la función
sv_setref_pvn
copia sizeof($var) caracteres a partir de la dirección
&$var (esto es, en el caso de nuestra llamada,
copia la cadena a partir de &RETVAL)
y dispone $arg para que referencie dicha zona.
El segundo argumento - ${ntype} es rectangular en nuestro caso -
indica en que clase se bendecirá $arg. El nuevo SV
$arg tendrá un contador de referencia de 1.
La traducción realizada por xsubpp
del código de new queda asi:
328 XS(XS_rectangular_new)
329 {
330 dXSARGS;
331 if (items != 1)
332 Perl_croak(aTHX_ "Usage: rectangular::new(CLASS)");
333 {
334 char * CLASS;
335 rectangular RETVAL;
336 #line 64 "Coord.xs"
337 Zero((void*)&RETVAL, sizeof(RETVAL), char);
338 #line 339 "Coord.c"
339 ST(0) = sv_newmortal();
340 sv_setref_pvn(ST(0), "rectangular", (char *)&RETVAL, sizeof(RETVAL));
341 }
342 XSRETURN(1);
343 }
La línea 340 es el resultado de la traducción
del esquema del typemap.
La asignación de la línea previa 339 crea
un nuevo SV con contador de referencia a 1.
Como dijimos, ese escalar sigue teniendo un contador de
referencia de 1 después de la línea 340.
¿Que ocurre cuando este código es llamado desde Perl?
my $r = rectangular->new();El hecho de que
$r referencia al valor escalar
creado en la línea 339 hace que este incremente
su contador de referencia pasando a valer 2 con lo
que la memoria asignada al SV nunca es liberada.
La llamada a sv_newmortal marca al SV
como mortal produciendo el decremento del contador
a la salida de la función:
lhp@nereida:~/Lperl/src/XSUB/h2xsexample/Coord/script$ perl -MDevel::Peek -Mblib -MCoord -de 0
main::(-e:1): 0
DB<1> $r = rectangular->new()
DB<2> Dump($r)
SV = PVMG(0x850e910) at 0x8494038
REFCNT = 1
FLAGS = (ROK)
IV = 0
NV = 0
RV = 0x8494068
SV = PVMG(0x8465968) at 0x8494068
REFCNT = 1
FLAGS = (OBJECT,POK,pPOK)
IV = 0
NV = 0
PV = 0x8479f10 "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"\0
CUR = 16
LEN = 20
STASH = 0x84626c4 "rectangular"
PV = 0x8494068 ""
CUR = 0
LEN = 0
DB<3> x $r
0 rectangular=SCALAR(0x8494068)
-> "\c@\c@\c@\c@\c@\c@\c@\c@\c@\c@\c@\c@\c@\c@\c@\c@"
Vemos que tanto $r como el escalar referenciado por $r tienen
sus REFCNT a 1. Podemos ver también como $r pertenece a la clase
rectangular.
Casiano Rodríguez León
