The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
use Test::More 'no_plan';
use strict;
use warnings;

use lib 't/object-simple';

BEGIN {
  $SIG{__WARN__} = sub {
    my $message = shift;
    
    unless ($message =~ /DEPRECATED/ && $message =~ /Object::Simple/) {
      warn $message;
    }
  };
}

# -base flag
{
  {
    use Some::T2;
    my $o = Some::T2->new;
    is($o->x, 1);
    is($o->y, 2);
  }
  
  {
    use T3;
    my $o = T3->new;
    is($o->x, 1);
    is($o->y, 2);
    is($o->z, 3);
  }
  
  {
    package T4;
    use Object::Simple -base => 'T3';
  }
  
  {
    my $o = T4->new;
    is($o->x, 1);
    is($o->y, 2);
    is($o->z, 3);
  }

  {
    package T4_2;
    use Object::Simple -base => 'T3_2';
  }
  
  {
    my $o = T4_2->new;
    is($o->x, 1);
    is($o->y, 2);
    is($o->z, 3);
  }
  
  {
    package T4_3;
    use Object::Simple 'T3_2';
  }

  {
    my $o = T4_3->new;
    is($o->x, 1);
    is($o->y, 2);
    is($o->z, 3);
  }
  
  {
    package T3_3;
    use T3 -base;
  }
  
  {
    my $o = T3_3->new;
    is($o->x, 1);
    is($o->y, 2);
    is($o->z, 3);
  }
}


# Test name
my $test;
sub test {$test = shift}

my $o;

# new();
{
  use T1;

  # Hash
  {
    my $o = T1->new(m1 => 1, m2 => 2);
    is_deeply($o, {m1 => 1, m2 => 2});
    isa_ok($o, 'T1');
  }
  
  # Hash reference
  {
    my $o = T1->new({m1 => 1, m2 => 2});
    is_deeply($o, {m1 => 1, m2 => 2});
    isa_ok($o, 'T1');
  }
  
  # No arguments
  {
    $o = T1->new;
    is_deeply($o, {});
  }
}

# accessor: attr, set and get
{
  my $o = T1->new;
  $o->m1(1);
  is($o->m1, 1);
}

# accessor array, set and get
{
  my $o = T1->new;
  $o->m4_1(1);
  is($o->m4_1, 1);
  $o->m4_2(1);
  is($o->m4_2, 1);
}

# Constructor
{
  # Hash
  {
    $o = T1->new(m1 => 1);
    is($o->m1, 1);
  }
  
  # Hash reference
  {
    $o = T1->new({m1 => 2});
    is($o->m1, 2);
  }
}

# Default option
{
  my $o = T1->new;
  
  # Scalar
  is($o->m11, 1);
  
  # code reference
  is($o->m12, 9);
}

# array and default
{
  # attr : first
  is($o->m18, 5);
  
  # attr : second
  is($o->m19, 5);
}

# Error
{
    package Some::T2;
    use base 'Object::Simple';

    eval{__PACKAGE__->attr(m1 => {})};
    Test::More::like($@, qr/Default has to be a code reference or constant value.*Some::T2::m1/,
         'default is not scalar or code ref');
}

# Method export
{
  {
    package T3;
    use Object::Simple qw/new attr/;
    __PACKAGE__->attr('m1');
  }
  
  {
    my $o = T3->new;
    $o->m1(1);
    is($o->m1, 1);
  }
}

# Method export error
{
  {
      package T4;
      eval "use Object::Simple '-none';";
  }
  like($@, qr/'-none' is invalid option/);
}

# Normal accessor
{
  $o = T1->new;
  $o->m1(1);
  is($o->m1, 1);
  is($o->m1(1), $o);
}

# Normal accessor with default
{
  {
    # set, get, return
    my $o = T1->new;
    $o->m11(2);
    is($o->m11, 2);
    is($o->m11(2), $o);
  }
  
  {
    # default, default sub reference
    my $o = T1->new;
    is($o->m11, 1);
    is($o->m12, 9);
  }
}

# new()
{
  # from class : hash
  {
    my $o = T1->new(m1 => 1);
    isa_ok($o, 'T1');
    is($o->m1, 1);
  }
  
  # from class : hash ref
  {
    my $o = T1->new({m1 => 1});
    isa_ok($o, 'T1');
    is($o->m1, 1);
  }
  
  # from object : hash
  {
    my $o = $o->new(m1 => 1);
    isa_ok($o, 'T1');
    is($o->m1, 1);
  }
  
  # from object : hash ref
  {
    my $o = $o->new({m1 => 1});
    isa_ok($o, 'T1');
    is($o->m1, 1);
  }
}

# Easy definition
{
  my $o = T1->new;
  ok($o->can('m33'), $test);
  ok($o->can('m34'), $test);
  is($o->m35, 1, $test);
  is($o->m36, 5, $test);
  is($o->m37, 1, $test);
  is($o->m38, 5, $test);
}

# Attr from object
{
  my $o = T1->new;
  $o->attr('from_object');
  ok($o->can('from_object'));
}