File Coverage

blib/lib/Class/MakeMethods/Emulator/Struct.pm

Criterion	Covered	Total	%
statement	31	38	81.5
branch	11	16	68.7
condition			n/a
subroutine	5	6	83.3
pod	0	1	0.0
total	47	61	77.0

package Class::MakeMethods::Emulator::Struct;

use strict;

use Class::MakeMethods;

use vars qw(@ISA @EXPORT);
require Exporter;
push @ISA, qw(Exporter);
@EXPORT = qw(struct);

sub import {
  my $self = shift;

  if ( @_ == 0 ) {
    $self->export_to_level( 1, $self, @EXPORT );
  } elsif ( @_ == 1 ) {
    $self->export_to_level( 1, $self, @_ );
  } else {
    &struct;
  }
}

########################################################################

my %type_map = (
  '$' => 'scalar',
  '@' => 'array',
  '%' => 'hash',
  '_' => 'object',
);

sub struct {
  my ($class, @decls);
  my $base_type = ref $_[1] ;
  if ( $base_type eq 'HASH' ) {
      $base_type = 'Standard::Hash';
      $class = shift;
      @decls = %{shift()};
      _usage_error() if @_;
  }
  elsif ( $base_type eq 'ARRAY' ) {
      $base_type = 'Standard::Array';
      $class = shift;
      @decls = @{shift()};
      _usage_error() if @_;
  }
  else {
      $base_type = 'Standard::Array';
      $class = (caller())[0];
      @decls = @_;
  }
  _usage_error() if @decls % 2 == 1;

  my @rewrite;
  while ( scalar @decls ) {
    my ($name, $type) = splice(@decls, 0, 2);
    push @rewrite, $type_map{$type}
      ? ( $type_map{$type} => { 'name'=>$name, auto_init=>1 } )
      : ( $type_map{'_'}   => { 'name'=>$name, 'class'=>$type, auto_init=>1 } );
  }
  Class::MakeMethods->make(
    -TargetClass => $class,
    -MakerClass => $base_type,
    "new" => 'new',
     @rewrite
  );
}

sub _usage_error {
  require Carp;
  Carp::confess "struct usage error";
}

########################################################################

1;

__END__