#!/usr/bin/perl
use strict;
use warnings;

########################################################################
########################################################################
########################################################################
package param_test;
use Carp;
use attributes;
use Scalar::Util;
use 5.10.0;

BEGIN
{
  my %found;
  my %allowed=(
    _      => ['TRUE',                                 sub{ 1 }],
    def    => ['Defined',                              sub{ defined($_[0]) }],
    int    => ['an Integer',                           sub{ defined($_[0]) && $_[0]!~/[^+\-\d]/ }],
    uint   => ['an Unsigned Integer',                  sub{ defined($_[0]) && $_[0]!~/\D/ }],
    number => ['a Number',                             sub{ defined($_[0]) && Scalar::Util::looks_like_number($_[0]) }],
    string => ['a String',                             sub{ defined($_[0]) && !Scalar::Util::reftype($_[0]) }],
    ref    => ['a Reference',                          sub{ Scalar::Util::reftype($_[0]) }],
    array  => ['an Anonyme Array',                     sub{ Scalar::Util::reftype($_[0]) && Scalar::Util::reftype($_[0]) eq 'ARRAY' }],
    hash   => ['an Anonyme Hash',                      sub{ Scalar::Util::reftype($_[0]) && Scalar::Util::reftype($_[0]) eq 'HASH' }],
    handle => ['a Reference to an Handle',             sub{ Scalar::Util::reftype($_[0]) && Scalar::Util::reftype($_[0]) eq 'GLOB' }],
    code   => ['an Anonyme Function',                  sub{ Scalar::Util::reftype($_[0]) && Scalar::Util::reftype($_[0]) eq 'CODE' }],
    object => ['an Object (blessed Reference)',        sub{ defined($_[0]) && Scalar::Util::blessed($_[0]) }],
    self   => ['an Object (blessed Reference of "%1")',sub{ defined($_[0]) && Scalar::Util::blessed($_[0]) && $_[0]->DOES($_[1]); }],
  );

  my $my_sprintf = sub
  {
    my $string=shift;
    while(1)
    {
      #$string=~s/%%/-!\0!-/gs;
      last unless($string=~s/((?:[^%]|^)(?:%%)*)%(\d+)/ $1.$_[$2-1] /egs);
    }
    #$string=~s/-!\0!-/%/gs;
    $string=~s/%%/%/gs;
    return $string;
  };

  sub MODIFY_CODE_ATTRIBUTES
  {
    my  $pkg = shift;
    my  $ref = shift;
    my ($param)=grep{ /^PARAM\s*\([^)]*\)\s*$/ }@_;

    next unless($param);

    my @opts;

    if($param=~/PARAM\s*\(\s*([^\)]+)\s*\)/s)
    {  @opts=split(/\s*?(?:,|;|\s+)\s*?/s,$1); }

    $found{$pkg}{$ref}=\@opts;
    return;
  }

  sub __INIT__
  {
    for my $pkg (keys(%found))
    {
      no strict 'refs';
      while(my ( $name , $symbol ) = each %{ $pkg . '::' })
      {
        no warnings 'once';
        my  $ref  = *{ $symbol }{ CODE } or next;
        next unless(exists($found{$pkg}{$ref}));
        for(@{$found{$pkg}{$ref}})
        { croak($my_sprintf->(q(for %1 Unknown PARAM "%2"),$symbol,$_)) unless(exists($allowed{$_})); }

        no warnings 'redefine';
        *{ $pkg . '::' . $name } = sub {

          croak($my_sprintf->(q(for %1::%2 @_ is to big),$pkg,$name)) if($#{$found{$pkg}{$ref}} < $#_);
          croak($my_sprintf->(q(for %1::%2 @_ is to smal),$pkg,$name)) if($#{$found{$pkg}{$ref}} > $#_);

          for(0..$#{$found{$pkg}{$ref}})
          {
            my $p=$found{$pkg}{$ref}->[$_];
            next if($allowed{$p}->[1]->($_[$_], $pkg, $name));
            croak($my_sprintf->(q(for %1::%2 $_[%3]="%4" is not %5!),$pkg,$name,$_,$_[$_],$allowed{$p}->[0]));
          }

          goto $ref;
        } # sub end
      }
    }
  }
}

INIT{ __PACKAGE__->__INIT__(); }

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

package ttt;
use base 'param_test';

sub new : PARAM(string)
{
  my $class=shift;
  bless({},$class);
}

sub test1 : PARAM(self string array hash)
{
  my ($self,$txt,$aref,$href)=@_;
  for(0..$#$aref)
  {
    my $s=$aref->[$_];
    print "$txt: $href->{$s}\n" if(exists($href->{$s}));
  }
}

sub test2 : PARAM(self string)
{
  my ($self,$txt)=@_;
  print "OUTPUT: $txt";
}

sub test3 : PARAM(self uint)
{
  my ($self,$int)=@_;
  print "TEXT($_)\n" for(1..$int);
}

#-----------------------------------------------------------------------
package main;
my $t=ttt->new();
$t->test1('TEST',[qw(a b c)],{a=>'TESTA', b=>'TetstB', d=>'TetstD'});
$t->test3(5);

#$t->new();

# stirbt mit Fehler:
ttt->test1('TEST',[qw(a b c)],{a=>'TESTA', b=>'TetstB', d=>'TetstD'});