view release on metacpan or  search on metacpan

lib/Class/Accessor/Fast/GXS.pm  view on Meta::CPAN

    } while @parts;
    unless ( $found ) {
        warn "not found dynamic library for $class" if $DEBUG;
        return $self->$method($field, @_);
    }

    return \&{"${class}::__xs_$name"}
        if defined &{"${class}::__xs_$name"};

    warn "C lib has no $name in $class" if $DEBUG;
    return $self->$method($field, @_);
}

my %handles = ();
sub __get_handle_for_xs {
    my $self = shift;
    my $class = ref $self || $self;
    my $module = $MODULE || $class;

    my $fh = $handles{ $module };
    return $fh if $fh;

    my $fn = $GENERATE_TO;
    $fn = join '/', $GENERATE_TO, split /::/, $module .".xs"
        if -d $GENERATE_TO;

    open $fh, ">", $fn or die "couldn't open file '$fn': $!";
    $handles{ $module } = $fh;

    print $fh $head, "\n\n";

    return $fh;
}

# XXX: escaping and unicode support
my %done = ();

sub make_ro_accessor {
    my $self = shift;
    my $field = shift;
    my $name = $self->accessor_name_for($field);
    return $self->__xs_load_or_fallback_to_super('make_ro_accessor', $name, $field, @_)
        unless defined $GENERATE_TO;

    my $class = ref $self || $self;
    return if $done{$class."::".$name}++;

    warn "making $field ro accessor for $class" if $DEBUG;

    my $fh = $self->__get_handle_for_xs;
    print $fh "MODULE = ". ($MODULE||$class) ." PACKAGE = $class\n\n";

    my $length = length $field;
    print $fh <<END;
void
__xs_$name(self)
    SV* self;
  PROTOTYPE: DISABLE
  INIT:
    SV** res;
  PPCODE:
    res = hv_fetch((HV *)SvRV(self), "$field", $length, 0);
    if (res == NULL)
        XSRETURN_UNDEF;

    XPUSHs(*res);

END

    return undef;
}

sub make_wo_accessor {
    my $self = shift;
    my $field = shift;
    my $name = $self->mutator_name_for($field);
    return $self->__xs_load_or_fallback_to_super('make_wo_accessor', $name, $field, @_)
        unless defined $GENERATE_TO;

    my $class = ref $self || $self;
    return if $done{$class."::".$name}++;

    warn "making $field wo accessor for $class" if $DEBUG;

    my $fh = $self->__get_handle_for_xs;
    print $fh "MODULE = ". ($MODULE||$class) ." PACKAGE = $class\n\n";

    my $length = length $field;
    print $fh <<END;
void
__xs_$name(self, ...)
    SV* self;
  PROTOTYPE: DISABLE
  INIT:
    SV **res;
    SV *newvalue;
    IV i;
  PPCODE:
    if ( items == 2 ) {
        newvalue = SvREFCNT_inc(ST(1));
    } else if ( items > 2 ) {
        AV* tmp = newAV();
        av_extend(tmp, items-1);
        for(i = 1; i < items; i++) {
            if (!av_store(tmp, i - 1, SvREFCNT_inc(ST(i)))) {
                SvREFCNT_dec(ST(i));
                croak("Cannot store value in array");
            }
        }
        newvalue = newRV_noinc((SV*) tmp);
    } else {
        croak("Cannot access the value");
    }

    if (res = hv_store((HV*)SvRV(self), "$field", $length, newvalue, 0)) {
        XPUSHs(*res);
    } else {
        SvREFCNT_dec(newvalue);
        croak("Failed to write new value to hash.");
        XSRETURN_UNDEF;
    }

END

    return undef;
}

sub make_accessor {
    my $self = shift;
    my $field = shift;
    # doesn't matter here what to call, they are equal
    my $name = $self->mutator_name_for($field);
    return $self->__xs_load_or_fallback_to_super('make_accessor', $name, $field, @_)
        unless defined $GENERATE_TO;

    my $class = ref $self || $self;
    return if $done{$class."::".$name}++;

    warn "making $field accessor for $class" if $DEBUG;

    my $fh = $self->__get_handle_for_xs;
    print $fh "MODULE = ". ($MODULE||$class) ." PACKAGE = $class\n\n";

    my $length = length $field;
    print $fh <<END;
void
__xs_$name(self, ...)
    SV* self;
  PROTOTYPE: DISABLE
  INIT:
    SV **res;
    SV *newvalue;
    IV i;
  PPCODE:
    if ( items == 1 ) {
        res = hv_fetch((HV *)SvRV(self), "$field", $length, 0);
        if (res == NULL)
            XSRETURN_UNDEF;

        XPUSHs(*res);
        XSRETURN(1);
    }
    else if ( items == 2 ) {
        newvalue = SvREFCNT_inc(ST(1));
    }
    else {
        AV* tmp = newAV();
        av_extend(tmp, items-1);
        for(i = 1; i < items; i++) {
            if (!av_store(tmp, i - 1, SvREFCNT_inc(ST(i)))) {
                SvREFCNT_dec(ST(i));
                croak("Cannot store value in array");
            }
        }
        newvalue = newRV_noinc((SV*) tmp);
    }

    if (res = hv_store((HV*)SvRV(self), "$field", $length, newvalue, 0)) {
        XPUSHs(*res);
    } else {
        SvREFCNT_dec(newvalue);
        croak("Failed to write new value to hash.");
        XSRETURN_UNDEF;
    }

END

    return undef;
}

1;

__END__

=head1 AUTHOR

Ruslan Zakirov E<lt>ruz@bestpractical.comE<gt>

=head1 LICENSE

This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut