Атрибуты для подпрограмм. Пре- и пост-вычисления , Perl v5.26x

[Tishaishii]

Стараюсь разобраться с атрибутами в Perl v5.26x.

use Attribute::Handlers ;
 
sub decorator( $\*&\@\@$$$ ):ATTR {
    my ( $package , $symbol, $referent, $attr , $data, $phase, $filename, $linenum ) = @_ ;
    my ( $before , $after ) = @$data ;
 
    # before processing
    $before->( @_ ) ;
 
    # decorated sub
    my $result = $referent->( ) ;
 
    # after processing
    $after->( $result )
}
 
sub c( $$ ):decorator(
    # before
    sub( $\*&\@\@$$$ ) {
        warn 'before' ;
    } ,
    # after
    sub( $ ) {
        warn 'after' ;
 
        shift( @_ ) + 1
    }
) {
    warn 'middle' ;
 
    pop( @_ ) + 1
}
 
print( __PACKAGE__->c( 123 ) ) ;

Хочется создать декоратор для метода `main::c` с препроцессингом и постпроцессингом. Что-то идёт не так.
Ожидался вывод:
```
before
middle
after
125
```

Получаю:
```
before
middle
after
middle
124
```

А нужна обёртка вокруг `middle`.
Как это решается?

Сообщение отредактировано: Tishaishii - 27.03.23, 07:28

[Tishaishii]

Уже сам вывернулся:

use Attribute::Handlers ;
 
sub decorator( $\*&\@\@$$$ ):ATTR {
    my ( undef( ) , $symbol, $referent , undef( ) , $data ) = @_ ;
    my ( $before , $after ) = @$data ;
 
    *$symbol = sub {
        $after->( $referent->( $before->( @_ ) ) )
    }
}
 
sub c( $$ ):decorator(
    # before
    sub( $$ ) {
        warn 'before' ;
 
        pop( @_ ) + 111
    } ,
    # after
    sub( $ ) {
        warn 'after' ;
 
        pop( @_ ) + 1
    }
) {
    warn 'middle' ;
 
    pop( @_ ) + 1
}
 
print( __PACKAGE__->c( 123 ) ) ;

А то предлагали страшный-страшный код. Если присмотреться, то понятный, но выше ж гораздо читаемей и без доп.пакета:

use Attribute::Handlers;
use Sub::Name qw( subname );
 
sub Wrap :ATTR(CODE) {
   my ( $pkg, $sym, $old_sub, $attr, $data, $phase, $fn, $ln ) = @_;
   my ( $before, $after ) = @$data;
 
   my $name = *{ $sym }{ NAME };
 
   my $new_sub = subname "wrapped_$name", sub {
      $before->( \@_ );
      my @rv = wantarray ? $old_sub->( @_ ) : scalar( $old_sub->( @_ ) );
      return $after->( \@_, @rv );
   };
 
   no warnings qw( redefine );
   *$sym = $new_sub;
}

Сообщение отредактировано: Tishaishii - 27.03.23, 10:54