Commit 7dbab981 by PotatoGim

perl: custom subroutine attribute example

parent 26180ceb
#!/usr/bin/env perl
#===========================================================================
# FILE: custom_attr.pl
# USAGE: ./custom_attr.pl
# DESCRIPTION:
# VERSION: 0.1
# OPTIONS: ---
# NOTES: ---
# AUTHOR: Ji-Hyeon Gim <potatogim@potatogim.net>
# COPYRIGHT: Copyleft 2018 by Ji-Hyeon Gim.
# LICENSE: Artistic License 2.0
# DATE: 2018년 02월 10일 01시 31분 06초
#===========================================================================
our $AUTHOR = "cpan:potatogim";
our $VERSION = "0.1";
package My::SubAttr;
use strict;
no strict qw/refs/;
use warnings;
no warnings qw/once reserved redefine/;
use B qw/svref_2object/;
use Carp;
use Data::Dumper;
our %allowed;
BEGIN
{
%allowed = (
Private => sub
{
my $package = shift;
return sub {
my ($coderef, @args) = @_;
my ($calling_package, $filename, $line, $sub) = caller(2);
croak 'Only the object may call this sub' unless $sub && $sub =~ /^$package\:\:/;
$coderef->(@args);
}
},
# compile time override, run a coderef after running the subroutine
After => sub
{
my ($package, $value, $coderef) = @_;
# full name of the sub to override
my $fq_sub = "$package:\:$value";
print "fq_sub: $fq_sub\n";
my $target_coderef = \&{$fq_sub};
*{$fq_sub} = sub
{
my @rv = $target_coderef->(@_);
$coderef->(@_);
return wantarray ? @rv : $rv[0];
};
# we didn't change the method with the attribute
# so we return undef as we have no runtime changes
return undef;
}
);
}
sub MODIFY_CODE_ATTRIBUTES
{
my ($package, $coderef, @attrs, @disallowed) = @_;
my $subname = svref_2object($coderef)->GV->NAME;
foreach my $attr (@attrs)
{
print "attr : $attr\n";
# parse the attribute into name and value
my ($name, $value) = $attr =~ qr/^ (\w+) (?:\((\S+?)\))? $/x;
printf "name : %s\n", $name // 'undef';
printf "value : %s\n", $value // 'undef';
# attribute not known, compile error
push(@disallowed, $name) && next unless exists $My::SubAttr::allowed{$name};
# override subroutine with attribute coderef
my $overrider = $My::SubAttr::allowed{$name}->($package, $value, $coderef);
next unless $overrider;
# override the subroutine if necessary
my $old_coderef = $coderef;
$coderef = sub { $overrider->($old_coderef, @_) };
*{"$package:\:$subname"} = $coderef;
}
$My::SubAttr::attrs{$package}{$subname} = \@attrs;
return @disallowed;
}
sub _internal_function : Private
{
print "INTERNAL\n";
return;
}
sub external
{
shift->_internal_function();
}
sub foo
{
print "foo() is called\n";
}
sub bar : After(foo)
{
print "bar() is called\n";
}
sub new
{
bless {}, shift;
}
sub FETCH_CODE_ATTRIBUTES
{
my ($class, $coderef) = @_;
my $cv = svref_2object($coderef);
return @{$My::SubAttr::attrs{$class}{$cv->GV->NAME}};
}
sub sub_attr
{
my $package = shift;
my $class = ref($package) || $package;
return \%My::SubAttr::attrs;
}
package Foo;
use base 'My::SubAttr';
sub new
{
bless {}, shift;
}
package main;
use Try::Tiny;
my $obj = My::SubAttr->new();
try
{
$obj->_internal_function();
}
catch
{
warn "@_";
};
try
{
$obj->external();
}
catch
{
warn "@_";
};
$obj->foo();
$obj = Foo->new();
printf("Class : %s\n", Foo->sub_attr() // 'undef');
printf("Object : %s\n", $obj->sub_attr() // 'undef');
=encoding utf8
=head1 NAME
custom_attr.pl -
=head1 SYNOPSIS
=head1 DESCRIPTION
=head1 AUTHOR
Ji-Hyeon Gim E<lt>potatogim@potatogim.netE<gt>
=head1 CONTRIBUTORS
=head1 COPYRIGHT AND LICENSE
Copyleft 2018 by Ji-Hyeon Gim.
This is free software; you can redistribute it and/or modify it
under the same terms as Perl 5 itself at:
L<http://www.perlfoundation.org/artistic_license_2_0>
You may obtain a copy of the full license at:
L<http://www.perl.com/perl/misc/Artistic.html>
=head1 SEE ALSO
=head1 DATE
2018년 02월 10일 01시 31분 06초
=cut
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment