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
|
/* You may distribute under the terms of either the GNU General Public License
* or the Artistic License (the same terms as Perl itself)
*
* (C) Paul Evans, 2009,2022 -- leonerd@leonerd.org.uk
*/
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
/* We don't actually use any magic routines; we apply magic simply for the
* side-effect of having our own private mg_object field to store the
* attributes hash. But we need a vtbl anyway.
* Also we use it to have a unique address to use to recognise ourself
*/
static MGVTBL vtbl = {
NULL, /* get */
NULL, /* set */
NULL, /* len */
NULL, /* clear */
NULL, /* free */
};
MODULE = Attribute::Storage PACKAGE = Attribute::Storage
void
_get_attr_hash(rv, create)
SV *rv
int create
INIT:
SV *subject;
SV *hash = NULL;
MAGIC *magic;
PPCODE:
if(!SvROK(rv))
croak("Cannot fetch attributes hash of a non-reference value");
subject = SvRV(rv);
if(SvTYPE(subject) >= SVt_PVMG)
/* Perl doesn't like calling mg_find() on non-magical SVs */
for(magic = mg_find(subject, PERL_MAGIC_ext); magic; magic = magic->mg_moremagic) {
if(magic->mg_type == PERL_MAGIC_ext && magic->mg_virtual == &vtbl) {
hash = magic->mg_obj;
break;
}
}
if(!hash && !create)
XSRETURN_UNDEF;
if(!hash) {
hash = sv_2mortal((SV*)newHV());
/* sv_magicext() will inc the hash's refcount, we don't want it here
*/
magic = sv_magicext(subject, hash, PERL_MAGIC_ext, &vtbl, NULL, 0);
/* Set the magic signature to 0; we'll use our vtable address to
* reliably recognise our own structure. 0 means it's unlikely to be
* falsely recognised by anyone else as belonging to them.
*/
magic->mg_private = 0;
}
XPUSHs(sv_2mortal(newRV_inc(hash)));
XSRETURN(1);
|
