#!perl -w
; use strict
; use Test::More tests => 74

; common_test('BaseClass', 'BaseClass');
; common_test('BaseClass', 'SubClass');

; sub common_test
   { my ($class, $subclass) = @_
   ; no strict 'refs'
   ; my $o1 = $subclass->new
   ; isa_ok( $o1
           , $class
           , 'Object creation'
           )

   ; my $o2 = $subclass->new( BpropA => 25
                            , BpropB => 3
                            )
   ; is( $o2->BpropA * $o2->BpropB
       , 75
       , 'Passing new properties with new' )

   ; is( $subclass->BpropA * $subclass->BpropB
       , 75
       , 'Accessing properties with subclass' )

   ; is( $class->BpropA * $class->BpropB
       , 75
       , 'Accessing properties with class' )

       
   ; is( ${$class.'::BpropA'} * ${$class.'::BpropB'}
       , 75
       , 'Passing new properties with new (underlaying scalar check)'
       )

   ; is( $o1->BpropA * $o1->BpropB
       , 75
       , 'Other object same test' )
        
   ; is( ${$class.'::BpropA'} * ${$class.'::BpropB'}
       , 75
       , 'Other object same test (underlaying scalar check)' )
        
   ; eval
      { my $o3 = $subclass->new( unknown => 10 )
      }
   ; ok( $@
       , 'Passing an unknow property'
       )
    
   ; eval
      { my $o3 = $subclass->new( Bprot => 10 )
      }
   ; ok( $@
       , 'Passing a value to a protected property'
       )
    
   ; is( $subclass->Bdefault
       , 25
       , "Reading default"
       )

   ; is( $class->Bdefault
       , 25
       , "Reading default"
       )

   ; is( ${$class.'::Bdefault'}
       , 25
       , "Reading default (underlaying scalar check)"
       )

   ; $subclass->Bvalid = 5
   ; is( $subclass->Bvalid
       , 5
       , 'Writing an always valid property'
       )

   ; is( ${$class.'::Bvalid'}
       , 5
       , 'Writing an always valid property (underlaying scalar check)'
       )

   ; $subclass->writeBprotA(5)
   ; is( $subclass->BprotA
       , 5
       , "Writing protected property from class"    #####
       )
       
   ; is( ${$class.'::BprotA'}
       , 5
       , "Writing protected property from class (underlaying scalar check)"    #####
       )
       
   ; eval
      { $subclass->BprotA = 10
      }
   ; ok( $@
       , 'Trying to write a protected property from outside'
       )

   ; $subclass->writeBprotA(8)
   ; is( $subclass->BprotA
       , 8
       , "Writing again protected property from class"
       )
   ; is( ${$class.'::BprotA'}
       , 8
       , "Writing again protected property from class (underlaying scalar check)"
       )

   ; is( $subclass->Bvalidat('aawwwbb')
       , 'aawwwbb'
       , 'Writing a valid value'
       )
   ; is(  ${$class.'::Bvalidat'}
       , 'aawwwbb'
       , 'Writing a valid value (underlaying scalar check)'
       )

   ; eval
      { $subclass->Bvalidat = 10
      }
   ; ok( $@
       , 'Writing an invalid value'
       )
       
   ; is( $subclass->Bvalidat('aawwwbb')
       , 'aawwwbb'
       , 'Writing again a valid value'
       )
       
   ; is(  ${$class.'::Bvalidat'}
       , 'aawwwbb'
       , 'Writing again a valid value (underlaying scalar check)'
       )

   ; is( $subclass->Bvalidat_default('aawwwbb')
       , 'aawwwbb'
       , 'Writing a valid value in a property with default'
       )

   ; is(  ${$class.'::Bvalidat_default'}
       , 'aawwwbb'
       , 'Writing a valid value in a property with default (underlaying scalar check)'
       )

   ; ok( (not $subclass->Barr_namedA)
       , 'Default undef value'
       )

   ; ok( ( not ${$class.'::Barr_namedA'} )
       , 'Default undef value (underlaying scalar check)'
       )

   ; $subclass->Bdefault = 56
   ; undef $subclass->Bdefault
   ; is( $subclass->Bdefault
       , 25
       , 'Reset to default'
       )

   ; is( ${$class.'::Bdefault'}
       , 25
       , 'Reset to default (underlaying scalar check)'
       )

   ; $subclass->Bmod_input = 'abc'
   ; is( $subclass->Bmod_input
       , 'ABC'
       , 'Modifying input'
       )
   ; is( ${$class.'::Bmod_input'}
       , 'ABC'
       , 'Modifying input (underlaying scalar check)'
       )
       
   ; is( $subclass->Brt_default
       , 25
       , 'Passing a sub ref as the rt_default'
       )

   ; is( ${$class.'::Brt_default'}
       , 25
       , 'Passing a sub ref as the rt_default (underlaying scalar check)'
       )

   ; eval
      { $subclass->Brt_default_val
      }
   ; ok( $@
       , 'Passing an invalid sub ref as the rt_default'
       )

   ; is( $subclass->Brt_default_val_prot
       , 5
       , "Bypass protection for rt_default"
       )
   ; is( ${$class.'::Brt_default_val_prot'}
       , 5
       , "Bypass protection for rt_default (underlaying scalar check)"
       )
   }


; package BaseClass

; use Class::constr


; use Package::props ( qw | BpropA
                          BpropB
                        |
                   , { name      => 'BnamedA'
                     }
                   , { name      => [ qw| Barr_namedA
                                          Barr_namedB
                                        |
                                    ]
                     }
                   , { name       => 'Bdefault'
                     , default    => 25
                     }
                   , { name => 'Brt_default'
                     , default    => sub{ 25 }
                     }
                   , { name       => 'Brt_default_val_prot'
                     , default => sub{ 5 }
                     , validation => sub { $_ < 25 }
                     , protected => 1
                     }
                    , { name       => 'BprotA'
                     , protected  => 1
                     }
                   , { name       => 'Bvalid'
                     , validation => sub { 1 }
                     }
                   , { name       => 'Binvalid'
                     , validation => sub { 0 }
                     }
                   , { name       => 'Bvalidat'
                     , validation => sub { /www/ }
                     }
                   , { name       => 'Bvalidat_default'
                     , validation => sub { /www/ }
                     , default    => 'wwwddd'
                     }
                   , { name       => 'Bmod_input'
                     , validation => sub { $_ = uc }
                     }
                   )
; sub writeBprotA
   { my ($s, $v) = @_
   ; $s->BprotA = $v
   }
                                 
; package SubClass
; use base 'BaseClass'