/lib/KinoSearch/Object/Obj.pm
Perl | 240 lines | 207 code | 31 blank | 2 comment | 7 complexity | 7330d3a9021852e78eed13032e9aef54 MD5 | raw file
- package KinoSearch::Object::Obj;
- use KinoSearch;
- 1;
- __END__
- __BINDING__
- my $xs_code = <<'END_XS_CODE';
- MODULE = KinoSearch PACKAGE = KinoSearch::Object::Obj
- chy_bool_t
- is_a(self, class_name)
- kino_Obj *self;
- const kino_CharBuf *class_name;
- CODE:
- {
- kino_VTable *target = kino_VTable_fetch_vtable(class_name);
- RETVAL = Kino_Obj_Is_A(self, target);
- }
- OUTPUT: RETVAL
- void
- STORABLE_freeze(self, ...)
- kino_Obj *self;
- PPCODE:
- {
- CHY_UNUSED_VAR(self);
- if (items < 2 || !SvTRUE(ST(1))) {
- SV *retval;
- kino_ByteBuf *serialized_bb;
- kino_RAMFileHandle *file_handle = kino_RAMFH_open(NULL,
- KINO_FH_WRITE_ONLY | KINO_FH_CREATE, NULL);
- kino_OutStream *target = kino_OutStream_open((kino_Obj*)file_handle);
- Kino_Obj_Serialize(self, target);
- Kino_OutStream_Close(target);
- serialized_bb = Kino_RAMFile_Get_Contents(
- Kino_RAMFH_Get_File(file_handle));
- retval = XSBind_bb_to_sv(serialized_bb);
- KINO_DECREF(file_handle);
- KINO_DECREF(target);
- if (SvCUR(retval) == 0) { // Thwart Storable bug
- THROW(KINO_ERR, "Calling serialize produced an empty string");
- }
- ST(0) = sv_2mortal(retval);
- XSRETURN(1);
- }
- }
- =begin comment
- Calls deserialize(), and copies the object pointer. Since deserialize is an
- abstract method, it will confess() unless implemented.
- =end comment
- =cut
- void
- STORABLE_thaw(blank_obj, cloning, serialized_sv)
- SV *blank_obj;
- SV *cloning;
- SV *serialized_sv;
- PPCODE:
- {
- char *class_name = HvNAME(SvSTASH(SvRV(blank_obj)));
- kino_ZombieCharBuf *klass
- = CFISH_ZCB_WRAP_STR(class_name, strlen(class_name));
- kino_VTable *vtable = (kino_VTable*)kino_VTable_singleton(
- (kino_CharBuf*)klass, NULL);
- STRLEN len;
- char *ptr = SvPV(serialized_sv, len);
- kino_ViewByteBuf *contents = kino_ViewBB_new(ptr, len);
- kino_RAMFile *ram_file = kino_RAMFile_new((kino_ByteBuf*)contents, true);
- kino_RAMFileHandle *file_handle
- = kino_RAMFH_open(NULL, KINO_FH_READ_ONLY, ram_file);
- kino_InStream *instream = kino_InStream_open((kino_Obj*)file_handle);
- kino_Obj *self = Kino_VTable_Foster_Obj(vtable, blank_obj);
- kino_Obj *deserialized = Kino_Obj_Deserialize(self, instream);
- CHY_UNUSED_VAR(cloning);
- KINO_DECREF(contents);
- KINO_DECREF(ram_file);
- KINO_DECREF(file_handle);
- KINO_DECREF(instream);
- // Catch bad deserialize() override.
- if (deserialized != self) {
- THROW(KINO_ERR, "Error when deserializing obj of class %o", klass);
- }
- }
- void
- DESTROY(self)
- kino_Obj *self;
- PPCODE:
- /*
- {
- char *perl_class = HvNAME(SvSTASH(SvRV(ST(0))));
- warn("Destroying: 0x%x %s", (unsigned)self, perl_class);
- }
- */
- Kino_Obj_Destroy(self);
- END_XS_CODE
- my $synopsis = <<'END_SYNOPSIS';
- package MyObj;
- use base qw( KinoSearch::Object::Obj );
-
- # Inside-out member var.
- my %foo;
-
- sub new {
- my ( $class, %args ) = @_;
- my $foo = delete $args{foo};
- my $self = $class->SUPER::new(%args);
- $foo{$$self} = $foo;
- return $self;
- }
-
- sub get_foo {
- my $self = shift;
- return $foo{$$self};
- }
-
- sub DESTROY {
- my $self = shift;
- delete $foo{$$self};
- $self->SUPER::DESTROY;
- }
- END_SYNOPSIS
- my $description = <<'END_DESCRIPTION';
- All objects in the KinoSearch:: hierarchy descend from
- KinoSearch::Object::Obj. All classes are implemented as blessed scalar
- references, with the scalar storing a pointer to a C struct.
- ==head2 Subclassing
- The recommended way to subclass KinoSearch::Object::Obj and its descendants is
- to use the inside-out design pattern. (See L<Class::InsideOut> for an
- introduction to inside-out techniques.)
- Since the blessed scalar stores a C pointer value which is unique per-object,
- C<$$self> can be used as an inside-out ID.
- # Accessor for 'foo' member variable.
- sub get_foo {
- my $self = shift;
- return $foo{$$self};
- }
- Caveats:
- ==over
- ==item *
- Inside-out aficionados will have noted that the "cached scalar id" stratagem
- recommended above isn't compatible with ithreads -- but KinoSearch doesn't
- support ithreads anyway, so it doesn't matter.
- ==item *
- Overridden methods must not return undef unless the API specifies that
- returning undef is permissible. (Failure to adhere to this rule currently
- results in a segfault rather than an exception.)
- ==back
- ==head1 CONSTRUCTOR
- ==head2 new()
- Abstract constructor -- must be invoked via a subclass. Attempting to
- instantiate objects of class "KinoSearch::Object::Obj" directly causes an
- error.
- Takes no arguments; if any are supplied, an error will be reported.
- ==head1 DESTRUCTOR
- ==head2 DESTROY
- All KinoSearch classes implement a DESTROY method; if you override it in a
- subclass, you must call C<< $self->SUPER::DESTROY >> to avoid leaking memory.
- END_DESCRIPTION
- Clownfish::Binding::Perl::Class->register(
- parcel => "KinoSearch",
- class_name => "KinoSearch::Object::Obj",
- xs_code => $xs_code,
- bind_methods => [
- qw(
- Get_RefCount
- Inc_RefCount
- Dec_RefCount
- Get_VTable
- To_String
- To_I64
- To_F64
- Dump
- _load|Load
- Clone
- Mimic
- Equals
- Hash_Sum
- Serialize
- Deserialize
- Destroy
- )
- ],
- bind_constructors => ["new"],
- make_pod => {
- synopsis => $synopsis,
- description => $description,
- methods => [
- qw(
- to_string
- to_i64
- to_f64
- equals
- dump
- load
- )
- ],
- }
- );
- __COPYRIGHT__
- Copyright 2005-2011 Marvin Humphrey
- This program is free software; you can redistribute it and/or modify
- under the same terms as Perl itself.