view release on metacpan or  search on metacpan

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

END

my %failed_loads = ();
sub __xs_load_or_fallback_to_super {
    my $self = shift;
    my $method = 'SUPER::'. shift;
    my $field = shift;
    my $name = shift;
    my $class = ref $self || $self;

    no strict 'refs';

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

    my @parts = split /::/, $class;
    my $found = 0;
    do {
        local $@;
        my $module = join "::", @parts;
        if ( $failed_loads{$module} || !eval { require XSLoader; XSLoader::load($module); 1 } ) {
            $failed_loads{$module} = 1;
        } else {
            $found = 1;
        }
        pop @parts;
    } 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;