File Coverage

blib/lib/Rose/Object/MakeMethods/Generic.pm

Criterion	Covered	Total	%
statement	210	244	86.0
branch	173	242	71.4
condition	43	71	60.5
subroutine	34	36	94.4
pod	4	4	100.0
total	464	597	77.7

package Rose::Object::MakeMethods::Generic;

use strict;

use Carp();

our $VERSION = '0.859';

use Rose::Object::MakeMethods;
our @ISA = qw(Rose::Object::MakeMethods);

our $Have_CXSA;

TRY:
{
  local $@;

  eval
  {
    require Class::XSAccessor;

    (my $version = $Class::XSAccessor::VERSION) =~ s/_//g;

    unless($version >= 0.14)
    {
      die "Class::XSAccessor $Class::XSAccessor::VERSION is too old";
    }
  };

  $Have_CXSA = $@ ? 0 : 1;
}

our $Debug = 0;

sub scalar
{
  my($class, $name, $args) = @_;

  my %methods;

  my $key = $args->{'hash_key'} || $name;
  my $interface = $args->{'interface'} || 'get_set';

  if($interface eq 'get_set_init')
  {
    my $init_method = $args->{'init_method'} || "init_$name";

    $methods{$name} = sub
    {
      return $_[0]->{$key} = $_[1]  if(@_ > 1);

      return defined $_[0]->{$key} ? $_[0]->{$key} :
        ($_[0]->{$key} = $_[0]->$init_method());
    }
  }
  elsif($interface eq 'get_set')
  {
    if($Have_CXSA && !$ENV{'ROSE_OBJECT_NO_CLASS_XSACCESOR'})
    {
      $methods{$name} =
      {
        make_method => sub
        {
          my($name, $target_class, $options) = @_;

          $Debug && warn "Class::XSAccessor make method ($name => $key) in $target_class\n";

          Class::XSAccessor->import(
            accessors => { $name => $key },
            class     => $target_class,
            replace   => $options->{'override_existing'} ? 1 : 0);
        },
      };
    }
    else
    {
      $methods{$name} = sub
      {
        return $_[0]->{$key} = $_[1]  if(@_ > 1);
        return $_[0]->{$key};
      }
    }
  }
  else { Carp::croak "Unknown interface: $interface" }

  return \%methods;
}

sub boolean
{
  my($class, $name, $args) = @_;

  my %methods;

  my $key = $args->{'hash_key'} || $name;
  my $interface = $args->{'interface'} || 'get_set';

  if($interface eq 'get_set_init')
  {
    my $init_method = $args->{'init_method'} || "init_$name";

    $methods{$name} = sub
    {
      return $_[0]->{$key} = $_[1] ? 1 : 0  if(@_ > 1);

      return defined $_[0]->{$key} ? $_[0]->{$key} :
        ($_[0]->{$key} = $_[0]->$init_method() ? 1 : 0);
    }
  }
  elsif($interface eq 'get_set')
  {
    if(exists $args->{'default'})
    {
      if($args->{'default'})
      {
        $methods{$name} = sub
        {
          return $_[0]->{$key} = $_[1] ? 1 : 0  if(@_ > 1);
          return defined $_[0]->{$key} ? $_[0]->{$key} : ($_[0]->{$key} = 1)
        }
      }
      else
      {
        $methods{$name} = sub
        {
          return $_[0]->{$key} = $_[1] ? 1 : 0  if(@_ > 1);
          return defined $_[0]->{$key} ? $_[0]->{$key} : ($_[0]->{$key} = 0)
        }
      }
    }
    else
    {
      $methods{$name} = sub
      {
        return $_[0]->{$key} = $_[1] ? 1 : 0  if(@_ > 1);
        return $_[0]->{$key};
      }
    }
  }
  else { Carp::croak "Unknown interface: $interface" }

  return \%methods;
}

sub hash
{
  my($class, $name, $args) = @_;

  my %methods;

  my $key = $args->{'hash_key'} || $name;
  my $interface = $args->{'interface'} || 'get_set';

  if($interface eq 'get_set_init')
  {
    my $init_method = $args->{'init_method'} || "init_$name";

    $methods{$name} = sub
    {
      my($self) = shift;

      # If called with no arguments, return hash contents
      unless(@_)
      {
        $self->{$key} = $self->$init_method()  unless(defined $self->{$key});
        return wantarray ? %{$self->{$key}} : $self->{$key};
      }

      # If called with a hash ref, set value
      if(@_ == 1 && ref $_[0] eq 'HASH')
      {
        $self->{$key} = $_[0];
      }
      else
      {
        # If called with an index, get that value, or a slice for array refs
        if(@_ == 1)
        {
          # Initialize hash if undefined
          $self->{$key} = $self->$init_method()  unless(defined $self->{$key});

          return ref $_[0] eq 'ARRAY' ? @{$self->{$key}}{@{$_[0]}} :
                                        $self->{$key}{$_[0]};
        }

        # Push on new values and return complete set
        Carp::croak "Odd number of items in assigment to $name"  if(@_ % 2);

        while(@_)
        {
          local $_ = shift;
          $self->{$key}{$_} = shift;
        }
      }

      return wantarray ? %{$self->{$key}} : $self->{$key};
    }
  }
  elsif($interface eq 'get_set_inited')
  {
    $methods{$name} = sub
    {
      my($self) = shift;

      # If called with no arguments, return hash contents
      unless(@_)
      {
        $self->{$key} = {}  unless(defined $self->{$key});
        return wantarray ? %{$self->{$key}} : $self->{$key};
      }

      # If called with a hash ref, set value
      if(@_ == 1 && ref $_[0] eq 'HASH')
      {
        $self->{$key} = $_[0];
      }
      else
      {
        # If called with an index, get that value, or a slice for array refs
        if(@_ == 1)
        {
          return ref $_[0] eq 'ARRAY' ? @{$self->{$key}}{@{$_[0]}} :
                                        $self->{$key}{$_[0]};
        }

        # Push on new values and return complete set
        Carp::croak "Odd number of items in assigment to $name"  if(@_ % 2);

        while(@_)
        {
          local $_ = shift;
          $self->{$key}{$_} = shift;
        }
      }

      return wantarray ? %{$self->{$key}} : $self->{$key};
    }
  }
  elsif($interface eq 'get_set_all')
  {
    $methods{$name} = sub
    {
      my($self) = shift;

      # If called with no arguments, return hash contents
      return wantarray ? %{$self->{$key}} : $self->{$key}  unless(@_);

      # Set hash to arguments
      if(@_ == 1 && ref $_[0] eq 'HASH')
      {
        $self->{$key} = $_[0];
      }
      else
      {
        # Push on new values and return complete set
        Carp::croak "Odd number of items in assigment to $name"  if(@_ % 2);

        $self->{$key} = {};

        while(@_)
        {
          local $_ = shift;
          $self->{$key}{$_} = shift;
        }
      }

      return wantarray ? %{$self->{$key}} : $self->{$key};
    }
  }
  elsif($interface eq 'get_set_init_all')
  {
    my $init_method = $args->{'init_method'} || "init_$name";

    $methods{$name} = sub
    {
      my($self) = shift;

      # If called with no arguments, return hash contents
      unless(@_)
      {
        $self->{$key} = $self->$init_method()  unless(defined $self->{$key});
        return wantarray ? %{$self->{$key}} : $self->{$key};
      }

      # If called with no arguments, return hash contents
      return wantarray ? %{$self->{$key}} : $self->{$key}  unless(@_);

      # Set hash to arguments
      if(@_ == 1 && ref $_[0] eq 'HASH')
      {
        $self->{$key} = $_[0];
      }
      else
      {
        # Push on new values and return complete set
        Carp::croak "Odd number of items in assigment to $name"  if(@_ % 2);

        $self->{$key} = {};

        while(@_)
        {
          local $_ = shift;
          $self->{$key}{$_} = shift;
        }
      }

      return wantarray ? %{$self->{$key}} : $self->{$key};
    }
  }
  elsif($interface eq 'clear')
  {
    $methods{$name} = sub
    {
      $_[0]->{$key} = {}
    }
  }
  elsif($interface eq 'reset')
  {
    $methods{$name} = sub
    {
      $_[0]->{$key} = undef;
    }
  }
  elsif($interface eq 'delete')
  {
    $methods{($interface eq 'manip' ? 'delete_' : '') . $name} = sub
    {
      Carp::croak "Missing key(s) to delete"  unless(@_ > 1);

      delete @{shift->{$key}}{@_};
    }
  }
  elsif($interface eq 'exists')
  {
    $methods{$name . ($interface eq 'manip' ? '_exists' : '')} = sub
    {
      Carp::croak "Missing key argument"  unless(@_ == 2);
      defined $_[0]->{$key} ? exists $_[0]->{$key}{$_[1]} : undef;
    }
  }
  elsif($interface =~ /^(?:keys|names)$/)
  {
    $methods{$name} = sub
    {
      wantarray ? (defined $_[0]->{$key} ? keys %{$_[0]->{$key}} : ()) :
                  (defined $_[0]->{$key} ? [ keys %{$_[0]->{$key}} ] : []);
    }
  }
  elsif($interface eq 'values')
  {
    $methods{$name} = sub
    {
      wantarray ? (defined $_[0]->{$key} ? values %{$_[0]->{$key}} : ()) :
                  (defined $_[0]->{$key} ? [ values %{$_[0]->{$key}} ] : []);
    }
  }
  elsif($interface eq 'get_set')
  {
    $methods{$name} = sub
    {
      my($self) = shift;

      # If called with no arguments, return hash contents
      unless(@_)
      {
        return wantarray ? (defined $self->{$key} ? %{$self->{$key}} : ()) : $self->{$key}
      }

      # If called with a hash ref, set value
      if(@_ == 1 && ref $_[0] eq 'HASH')
      {
        $self->{$key} = $_[0];
      }
      else
      {
        # If called with an index, get that value, or a slice for array refs
        if(@_ == 1)
        {
          return ref $_[0] eq 'ARRAY' ? @{$self->{$key}}{@{$_[0]}} :
                                        $self->{$key}{$_[0]};
        }

        # Push on new values and return complete set
        Carp::croak "Odd number of items in assigment to $name"  if(@_ % 2);

        while(@_)
        {
          local $_ = shift;
          $self->{$key}{$_} = shift;
        }
      }

      return wantarray ? %{$self->{$key}} : $self->{$key};
    };
  }
  else { Carp::croak "Unknown interface: $interface" }

  return \%methods;
}

sub array
{
  my($class, $name, $args) = @_;

  my %methods;

  my $key = $args->{'hash_key'} || $name;
  my $interface = $args->{'interface'} || 'get_set';

  if($interface eq 'get_set_init')
  {
    my $init_method = $args->{'init_method'} || "init_$name";

    $methods{$name} = sub
    {
      my($self) = shift;

      # If called with no arguments, return array contents
      unless(@_)
      {
        $self->{$key} = $self->$init_method()  unless(defined $self->{$key});
        return wantarray ? @{$self->{$key}} : $self->{$key};
      }

      # If called with a array ref, set new value
      if(@_ == 1 && ref $_[0] eq 'ARRAY')
      {
        $self->{$key} = $_[0];
      }
      else
      {
        $self->{$key} = [ @_ ];
      }

      return wantarray ? @{$self->{$key}} : $self->{$key};
    }
  }
  elsif($interface eq 'get_set_inited')
  {
    $methods{$name} = sub
    {
      my($self) = shift;

      # If called with no arguments, return array contents
      unless(@_)
      {
        $self->{$key} = [] unless(defined $self->{$key});
        return wantarray ? @{$self->{$key}} : $self->{$key};
      }

      # If called with a array ref, set new value
      if(@_ == 1 && ref $_[0] eq 'ARRAY')
      {
        $self->{$key} = $_[0];
      }
      else
      {
        $self->{$key} = [ @_ ];
      }

      return wantarray ? @{$self->{$key}} : $self->{$key};
    }
  }
  elsif($interface eq 'get_set_item')
  {
    $methods{$name} = sub
    {
      my($self) = shift;

      Carp::croak "Missing array index"  unless(@_);

      if(@_ == 2)
      {
        return $self->{$key}[$_[0]] = $_[1];
      }
      else
      {
        return $self->{$key}[$_[0]]
      }
    }
  }
  elsif($interface eq 'unshift')
  {
    $methods{$name} = sub
    {
      my($self) = shift;
      Carp::croak "Missing value(s) to add"  unless(@_);
      unshift(@{$self->{$key}}, (@_ == 1 && ref $_[0] eq 'ARRAY') ? @{$_[0]} : @_);
    }
  }
  elsif($interface eq 'shift')
  {
    $methods{$name} = sub
    {
      my($self) = shift;
      return splice(@{$self->{$key}}, 0, $_[0])  if(@_);
      return shift(@{$self->{$key}})
    }
  }
  elsif($interface eq 'clear')
  {
    $methods{$name} = sub
    {
      $_[0]->{$key} = []
    }
  }
  elsif($interface eq 'reset')
  {
    $methods{$name} = sub
    {
      $_[0]->{$key} = undef;
    }
  }
  elsif($interface =~ /^(?:push|add)$/)
  {
    if(my $init_method = $args->{'init_method'})
    {
      $methods{$name} = sub
      {
        my($self) = shift;

        Carp::croak "Missing value(s) to add"  unless(@_);

        $self->{$key} = $self->$init_method()  unless(defined $self->{$key});
        push(@{$self->{$key}}, (@_ == 1 && ref $_[0] && ref $_[0] eq 'ARRAY') ? @{$_[0]} : @_);
      }
    }
    else
    {
      $methods{$name} = sub
      {
        my($self) = shift;

        Carp::croak "Missing value(s) to add"  unless(@_);

        push(@{$self->{$key}}, (@_ == 1 && ref $_[0] && ref $_[0] eq 'ARRAY') ? @{$_[0]} : @_);
      }
    }
  }
  elsif($interface eq 'pop')
  {
    $methods{$name} = sub
    {
      my($self) = shift;
      return splice(@{$self->{$key}}, -$_[0])  if(@_);
      return pop(@{$self->{$key}})
    }
  }
  elsif($interface eq 'get_set')
  {
    $methods{$name} = sub
    {
      my($self) = shift;

      # If called with no arguments, return array contents
      unless(@_)
      {
        return wantarray ? (defined $self->{$key} ? @{$self->{$key}} : ()) : $self->{$key}
      }

      # If called with a array ref, set new value
      if(@_ == 1 && ref $_[0] eq 'ARRAY')
      {
        $self->{$key} = $_[0];
      }
      else
      {
        $self->{$key} = [ @_ ];
      }

      return wantarray ? @{$self->{$key}} : $self->{$key};
    }
  }
  else { Carp::croak "Unknown interface: $interface" }

  return \%methods;
}

1;

__END__