view release on metacpan or  search on metacpan

lib/C/DynaLib/Struct.pm  view on Meta::CPAN

sub TIESCALAR {
    my ($class, @member) = @_;
    defined (${"${class}::template"})
	or croak "Class \"$class\" has not been defined as a Struct";
    bless [ undef, \@member ], $class;
}

sub AUTOLOAD {
    my $self = shift;
    my $class = ref ($self);
    (my $member = $AUTOLOAD) =~ s/.*:://;
    my $template = ${"${class}::template"};
    defined ($template)
	or croak "Class \"$class\" has not been defined as a Struct";
    my $index = ${"${class}::fieldno"}{$member};
    unless (defined ($index)) {
	carp "Struct \"$class\" has no member \"$member\""
	    unless $member eq 'DESTROY';
	return undef;
    }
    $self->[1] ||= [ unpack ($template, $self->[0]) ];
    if (@_ == 0) {
	return $self->[1]->[$index];
    } elsif (@_ == 1) {
	undef $self->[0];
	return $self->[1]->[$index] = $_[0];
    } else {
	croak "Usage: \$structref->$member( [\$new_value] )";
    }
}

sub FETCH {
    return $_[0]->[0] if defined ($_[0]->[0]);
    return $_[0]->[0] = pack (${ref ($_[0]) . "::template"}, @{$_[0]->[1]});
}

sub STORE {
    undef $_[0]->[1];
    $_[0]->[0] = $_[1];
}

sub Unpack {
    $_[0]->[1] = [ unpack (${ref ($_[0]) . "::template"}, $_[0]->[0]) ]
	if defined ($_[0]->[0]);
    return @{$_[0]->[1]} if wantarray;
}

package C::DynaLib::Struct;

use Carp;

sub Define {
    my ($class, $new_class) = splice(@_, 0, 2);
    if (defined (${"${new_class}::template"})) {
	carp "Redefinition of Struct $new_class";
    }
    *{"${new_class}::TIESCALAR"} = \&C::DynaLib::Struct::Imp::TIESCALAR;
    *{"${new_class}::AUTOLOAD"} = \&C::DynaLib::Struct::Imp::AUTOLOAD;
    @{"${new_class}::ISA"} = qw (C::DynaLib::Struct::Imp);
    my ($template, %fieldno) = ("");
    my ($index, $template_fragment, $fields) = (0);
    while (1) {
	($template_fragment, $fields) = splice(@_, 0, 2);
	last unless defined ($template_fragment);
	ref ($fields) eq 'ARRAY'
	    or die 'Usage: Define C::DynaLib::Struct( $struct_name, $template, \@field_names )';
	$template .= $template_fragment;
	my $i;
	for $i (0 .. $#$fields) {
	    defined (&{"C::DynaLib::Struct::Imp::$fields->[$i]"})
		and croak "Illegal Struct member name: \"$fields->[$i]\"";
	    $fieldno{$fields->[$i]} = $index;
	    ++ $index;
	}
    }
    *{"${new_class}::fieldno"} = \%fieldno;
    *{"${new_class}::template"} = \$template;
}

sub Parse {
  my $definition = shift;
  $definition = shift if $definition eq 'C::DynaLib::Struct';
  my $c;
  if (eval "require Convert::Binary::C;") {
    Convert::Binary::C->import;
    if (ref $definition eq 'Convert::Binary::C') {
      $c = $definition;
      $c->parse(@_);
    } else {
      require C::DynaLib::PerlTypes;
      $c = Convert::Binary::C->new(%$C::DynaLib::PerlTypes::PerlTypes);
      $c->parse($definition, @_);
    }
    # all structs and unions
    for my $s ($c->compound) {
      my $record = $s->{identifier};
      if (defined (${"${record}::template"})) { # already parsed
	carp "Redefinition of ".$s->{type}." $record\n";
      }
      # Convert::Binary::C bug in 0.74
      # fixup wrong declarations: 'char'(type) '*baz'(declarator) => 'char*' 'baz'
      for (0..@{$s->{declarations}}) {
	  my $d = $s->{declarations}->[$_];
	  if ($d and $d->{declarators}[0]->{declarator} 
	      and substr($d->{declarators}[0]->{declarator},0,1) eq '*')
	  {
	      $s->{declarations}->[$_]->{declarators}[0]->{declarator} =
		  substr($d->{declarators}[0]->{declarator},1);
	      $s->{declarations}->[$_]->{type} .= "*";
	  }
      }
      my @members = _members(@{$s->{declarations}});
      Define C::DynaLib::Struct($record,
				_pack_names(@{$s->{declarations}}),
				\@members);
    }
  } else {
    # XXX use GCC::TranslationUnit (does not work yet)
    my $node = C::DynaLib::Parse::GCC_prepare($definition);
    while ($node) {
      if ($node->isa('GCC::Node::function_decl')) {
	declare_func(process_func($node));
      }
      if ($node->isa('GCC::Node::record_type')) {
	declare_struct(process_struct($node));
      }
    } continue {