view release on metacpan or  search on metacpan

buildtools/makeNovaClass.pl  view on Meta::CPAN

    if (/^\s*$/ and $struct) {
      $structs{$struct->{name}} = $struct;
      $struct = undef;
      next;
    }
    next if /^\s*$/;

    if (not $struct) {
      /^\s*(\S+)\s+(\S.*)$/ or die;
      $struct = {members => {}};
      $struct->{name} = $2;
      $struct->{package} = $1;
      $struct->{name} =~ s/\s+$//;
    }
    else {
      /^\s*([^\t]+)\t+(.*)$/ or die;
      my ($mtype, $mname) = ($1, $2);
      $mtype =~ s/^\s+//; $mtype =~ s/\s+$//;
      $mname =~ s/^\s+//; $mname =~ s/\s+$//;
      $struct->{members}{$mname} = $mtype;
    }
  }
  if ($struct) {
    $structs{$struct->{name}} = $struct;
  }
  write_structs($oh, \%structs);
}

sub write_structs {
  my ($oh, $structs) = @_;
  foreach my $struct (values %$structs) {
    print $oh "\nMODULE=$module	PACKAGE=$struct->{package}\n\n";
    print $oh constructor($struct), "\n";
    print $oh destructor($struct), "\n";
    print $oh accessors($struct, $structs), "\n";
  }
}

sub accessors {
  my ($struct, $structs_hash) = @_;
  my $name = $struct->{name};
  my $members = $struct->{members};

  my @code;
  foreach my $field (keys %$members) {
    my $type = $members->{$field};
    if ($type !~ /^\s*struct/ or $type =~ /^\s*struct.*\*\s*$/) {
      push @code, <<HERE;
$type
get_$field( self )
	$name* self
    CODE:
	RETVAL = self->$field;
    OUTPUT:
	RETVAL

void
set_$field( self, val )
	$name* self
	$type val
    PPCODE:
	self->$field = val;
HERE
    }
    else {
      my $field_class = $structs_hash->{$type}{package};
      die "Can't find class for type '$type'" if not defined $field_class;
      push @code, <<HERE;
$type*
get_$field( self )
	$name* self
    INIT:
        const char* CLASS = "$field_class"; /* hack to work around perlobject.map */
    CODE:
	RETVAL = ($type*)safemalloc( sizeof( $type ) );
	if( RETVAL == NULL ){
		warn("unable to malloc $type");
		XSRETURN_UNDEF;
	}
        Copy(&(self->$field), (RETVAL), 1, $type);
    OUTPUT:
	RETVAL

void
set_$field( self, val )
	$name* self
	$type* val
    PPCODE:
        Copy(val, &(self->$field), 1, $type);
HERE
    }
  }
  return join("\n\n", @code)."\n";
}


sub destructor {
  my ($struct) = @_;
  my $name = $struct->{name};
  return <<HERE;
void
DESTROY(self)
	$name* self
    CODE:
	safefree( (char*)self );
HERE
}

sub constructor {
  my ($struct) = @_;
  my $name = $struct->{name};
  my $package = $struct->{package};
  my $initsection = '';
  my $assignsection = '';
  my @init = (
    {re     => qr/^\s*(?:unsigned\s+)?(?:int|long\s*long|long|short|char)\s*$/,
     init   => '0',
     assign => 'SvIV(*saveSV)',
    },
    {re     => qr/^\s*(?:double|float)\s*$/,
     init   => '0.',
     assign => 'SvNV(*saveSV)',
    },
    {re     => qr/^\s*struct\b/,
     init   => sub {my ($f, $t) = @_; "Zero(&(RETVAL->$f), 1, $t);" }, # hack
     assign => sub { # hack
        my ($f, $t) = @_;
        "if ( sv_isobject(*saveSV) && (SvTYPE(SvRV(*saveSV)) == SVt_PVMG) ) {
          $t* original = ($t*)SvIV((SV*)SvRV( *saveSV )); 
          Copy(original, &(RETVAL->$f), 1, $t);
        }
        else {
          warn(\"Invalid argument passed to constructor\");
          XSRETURN_UNDEF;
        }
        "
      },
    },
  );

  foreach my $field (keys %{$struct->{members}}) {
    my $type = $struct->{members}{$field};
    foreach my $init (@init) {
      my $re = $init->{re};

      if ($type =~ $re) {
        if (ref($init->{init})) {
          $initsection   .= "\n        " . $init->{init}->($field, $type);