root/dan/perl/Object-with/branches/yappo/lib/Object/with.pm @ 14699

Revision 14699, 1.5 kB (checked in by tokuhirom, 6 years ago)

shut up perlcritic

Line 
1package Object::with;
2
3use strict;
4use warnings;
5our $VERSION = '0.01';
6use Data::Dumper;
7
8use XSLoader;
9
10XSLoader::load 'Object::with', $VERSION;
11
12
13sub import {
14    my $class = shift;
15    my $pkg   = caller(0);
16    no strict 'refs';
17    *{"$pkg\::with"} = \&with;
18}
19
20our $TMP_OBJ;
21my %TMP_METHOD_CACHE;
22
23sub with ($&;@) { ## no critic
24    local $TMP_OBJ    = shift;
25    my $code          = shift;
26    _with($code);
27
28    my @ret = $code->(@_);
29
30    while (my($name, $code) = each %TMP_METHOD_CACHE) {
31        no strict 'refs';
32        no warnings 'redefine';
33        my($caller, $method) = $name =~ /^(.*)::(.*)$/;
34        if ($code && ref $code) {
35            *{$name} = $code;
36        } else {
37            *{$name} = sub{};
38        }
39        delete $TMP_METHOD_CACHE{$name};
40    }
41
42    _leave($code);
43
44    @ret;
45}
46
47sub _entersub {
48    return unless $TMP_OBJ;
49    my $name    = shift;
50    $name =~ s/^\*//;
51    my($method) = $name =~ /^.*::(.*)$/;
52    my $class   = ref($TMP_OBJ) || $TMP_OBJ;
53
54    no strict 'refs';
55    no warnings 'redefine';
56    $TMP_METHOD_CACHE{$name} = defined &{$name} ? \&{$name} : undef unless exists $TMP_METHOD_CACHE{$name};
57    *{$name}                 = sub { unshift @_, $TMP_OBJ; goto &{"$class\::$method"} };
58}
59
601;
61__END__
62
63=encoding utf8
64
65=head1 NAME
66
67Object::with -
68
69=head1 SYNOPSIS
70
71  use Object::with;
72
73=head1 DESCRIPTION
74
75Object::with is
76
77=head1 AUTHOR
78
79Kazuhiro Osawa E<lt>ko@yappo.ne.jpE<gt>
80
81=head1 SEE ALSO
82
83=head1 LICENSE
84
85This library is free software; you can redistribute it and/or modify
86it under the same terms as Perl itself.
87
88=cut
Note: See TracBrowser for help on using the browser.