| Subject: | Easier type maps |
| Date: | Wed, 26 Mar 2008 14:01:02 -0700 |
| To: | bug-XS-Writer [...] rt.cpan.org |
| From: | Michael G Schwern <schwern [...] pobox.com> |
Show quoted text
-------- Original Message --------
Subject: Re: XS::Writer
Date: Sat, 22 Mar 2008 02:53:19 -0700
From: Tom Heady <tom@heady.org>
To: Michael G Schwern <schwern@pobox.com>
References: <47E38E25.6030802@pobox.com> <47E488AE.2040701@heady.org>
Tom Heady wrote:
> Michael G Schwern wrote:
Attached is a patch which makes it easier to map types. Just define
which SV field you want at the top of Writer.pm for each type.
Oh yeah, and tests too.
Tom
--
I do have a cause though. It's obscenity. I'm for it.
- Tom Lehrer
>> Hey folks, you might be interested in a module I just whipped up to
>> generate the necessary XS code to make objects out of structs.
>> http://svn.schwern.org/svn/CPAN/XS-Writer/
>>
>
> We should come up with a more generic way to map types. I have a
> struct with uint32_t and uint64_t that are fairly easy to map.
>
Index: t/type_accessor.t
===================================================================
--- t/type_accessor.t (revision 0)
+++ t/type_accessor.t (revision 0)
@@ -0,0 +1,150 @@
+#!/usr/bin/perl -w
+
+use Test::More tests => 7;
+use Test::Differences;
+use Test::Exception;
+
+use File::Path;
+
+
+use_ok 'XS::Writer';
+
+my $writer = XS::Writer->new(
+ package => 'Some::Employee'
+);
+
+$writer->type_accessor(completelymadeuptype => <<'END');
+$type
+$accessor( $class self, ... )
+ CODE:
+ if( items > 1 )
+ self->$key = SvIV(ST(1));
+ RETVAL = self->$key;
+ OUTPUT:
+ RETVAL
+END
+
+{
+ $writer->struct(<<' END');
+ typedef struct employee {
+ completelymadeuptype hair_color;
+ };
+ END
+
+ my $wanted = <<' END';
+completelymadeuptype
+Some__Employee_hair_color( Some::Employee self, ... )
+ CODE:
+ if( items > 1 )
+ self->hair_color = SvIV(ST(1));
+ RETVAL = self->hair_color;
+ OUTPUT:
+ RETVAL
+
+
+ END
+
+ eq_or_diff( $writer->make_xs_accessors , $wanted , 'completelymadeuptype mapped correctly' );
+}
+
+
+{
+ $writer->struct(<<' END');
+ typedef struct employee {
+ char * name;
+ };
+ END
+
+ my $wanted = <<' END';
+char *
+Some__Employee_name( Some::Employee self, ... )
+ CODE:
+ if( items > 1 )
+ self->name = SvPV_nolen(ST(1));
+ RETVAL = self->name;
+ OUTPUT:
+ RETVAL
+
+
+ END
+
+ eq_or_diff( $writer->make_xs_accessors , $wanted , 'char * mapped correctly' );
+}
+
+{
+ $writer->struct(<<' END');
+ typedef struct employee {
+ double salary;
+ };
+ END
+
+ my $wanted = <<' END';
+double
+Some__Employee_salary( Some::Employee self, ... )
+ CODE:
+ if( items > 1 )
+ self->salary = SvNV(ST(1));
+ RETVAL = self->salary;
+ OUTPUT:
+ RETVAL
+
+
+ END
+ eq_or_diff( $writer->make_xs_accessors , $wanted , 'double mapped correctly' );
+}
+
+{
+ $writer->struct(<<' END');
+ typedef struct employee {
+ int id;
+ };
+ END
+
+ my $wanted = <<' END';
+int
+Some__Employee_id( Some::Employee self, ... )
+ CODE:
+ if( items > 1 )
+ self->id = SvIV(ST(1));
+ RETVAL = self->id;
+ OUTPUT:
+ RETVAL
+
+
+ END
+ eq_or_diff( $writer->make_xs_accessors , $wanted , 'int mapped correctly' );
+}
+
+{
+ $writer->struct(<<' END');
+ typedef struct employee {
+ uint32_t age;
+ };
+ END
+
+ my $wanted = <<' END';
+uint32_t
+Some__Employee_age( Some::Employee self, ... )
+ CODE:
+ if( items > 1 )
+ self->age = SvUV(ST(1));
+ RETVAL = self->age;
+ OUTPUT:
+ RETVAL
+
+
+ END
+ eq_or_diff( $writer->make_xs_accessors , $wanted , 'uint32_t mapped correctly' );
+}
+
+{
+ $writer->struct(<<' END');
+ typedef struct employee {
+ doesnotexist num_fingers;
+ };
+ END
+
+ eval{ $writer->make_xs_accessors };
+ like( $@ , qr{\ANo accessor for type doesnotexist} ,
+ 'throw error for unknown types' );
+}
Index: lib/XS/Writer.pm
===================================================================
--- lib/XS/Writer.pm (revision 4268)
+++ lib/XS/Writer.pm (working copy)
@@ -11,6 +11,20 @@
use Moose;
use Moose::Autobox;
+my $typemap = {
+ 'char *' => 'SvPV_nolen',
+ int => 'SvIV',
+ double => 'SvNV',
+ 'unsigned int' => 'SvUV',
+ long => 'SvIV',
+ 'unsigned long' => 'SvUV',
+ short => 'SvIV',
+ 'unsigned short' => 'SvUV',
+ 'unsigned char *' => 'SvPV_nolen',
+ 'const char *' => 'SvPV_nolen',
+ uint32_t => 'SvUV',
+};
+
{
package StringWithWhitespace;
use Moose::Role;
@@ -206,43 +220,33 @@
my $class = shift;
my $self = $class->SUPER::new(@_);
- $self->type_accessor(int => <<'END');
-$type
-$accessor( $class self, ... )
- CODE:
- if( items > 1 )
- self->$key = SvIV(ST(1));
- RETVAL = self->$key;
- OUTPUT:
- RETVAL
-END
+ return $self;
+}
- $self->type_accessor("char *" => <<'END');
-$type
-$accessor( $class self, ... )
- CODE:
- if( items > 1 )
- self->$key = SvPV_nolen(ST(1));
- RETVAL = self->$key;
- OUTPUT:
- RETVAL
-END
+sub _build_accessor
+{
+ my $self = shift;
+ my $type = shift;
- $self->type_accessor(double => <<'END');
+ my $accessors = $self->type_accessors;
+
+ # if the user specified a type, return it
+ return $accessors->{$type} if $accessors->{$type};
+
+ # return the default
+ return $self->type_accessor($type => <<'END');
$type
$accessor( $class self, ... )
CODE:
if( items > 1 )
- self->$key = SvNV(ST(1));
+ self->$key = $map(ST(1));
RETVAL = self->$key;
OUTPUT:
RETVAL
END
- return $self;
}
-
=head3 struct
$writer->struct($typedef);
@@ -371,22 +375,28 @@
return $xs;
}
-
sub make_xs_accessors {
my $self = shift;
my $xs = '';
my $elements = $self->struct_elements;
- my $accessors = $self->type_accessors;
my $xs_type = $self->xs_type;
for my $key (sort { lc $a cmp lc $b } keys %$elements) {
my $type = $elements->{$key};
- my $accessor = $accessors->{$type}
- or croak "No accessor for type $type";
+ my $accessor = $self->_build_accessor( $type );
+
+ my $map = $typemap->{ $type };
+
+ if ( $accessor =~ /\$map/ and ! $map )
+ {
+ croak "No accessor for type $type";
+ }
+
$accessor =~ s/\$accessor/${xs_type}_${key}/g;
$accessor =~ s/\$key/$key/g;
+ $accessor =~ s/\$map/$map/g;
$xs .= $accessor;
$xs .= "\n\n";
@@ -395,7 +405,6 @@
return $xs;
}
-
sub make_xs {
my $self = shift;