Commit 586fb41b by PotatoGim

generator example

parent 53d49137
#!/usr/bin/env perl
#===========================================================================
# FILE: generator.pl
# USAGE: ./generator.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월 11일 01시 01분 16초
#===========================================================================
our $AUTHOR = "cpan:potatogim";
our $VERSION = "0.1";
package My::Generator;
use utf8;
use strict;
use warnings;
no strict qw/refs/;
no warnings qw/once reserved redefine/;
use B qw/svref_2object/;
our %allowed;
BEGIN
{
%allowed = (
generator => sub
{
my $package = shift;
return sub {
my ($coderef, @args) = @_;
$coderef->(@args);
};
}
);
}
sub MODIFY_CODE_ATTRIBUTES
{
my ($package, $coderef, @attrs) = @_;
my @disallowed;
my $subname = svref_2object($coderef)->GV->NAME;
foreach my $attr (@attrs)
{
# 1. parse the attr into name/value
my ($name, $value) = $attr =~ qr/^ (\w+) (?:\((\S+?)\))? $/x;
# 2. raise an exception for unknown attr
push(@disallowed, $name) && next if (!*{__PACKAGE__ . '::allowed'}{HASH}{$name});
# 3. make overrider for this attr
my $overrider = *{__PACKAGE__ . '::allowed'}{HASH}{$name}->($package, $value, $coderef);
next unless $overrider;
# 4. override the subroutine
my $old_coderef = $coderef;
$coderef = sub { $overrider->($old_coderef, @_); };
*{__PACKAGE__ . '::' . $subname} = $coderef;
}
$__PACKAGE__::code_attributes{$package}{$subname} = \@attrs;
return @disallowed;
}
sub new
{
bless({}, shift);
}
package My::Dir;
use base qw/My::Generator/;
sub scandir : generator
{
my $self = shift;
print "scandir() is called\n";
return 0;
}
package main;
my $dir = My::Dir->new();
$dir->scandir();
=encoding utf8
=head1 NAME
generator.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월 11일 01시 01분 16초
=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