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

package Object::with;

use strict;
use warnings;
our $VERSION = '0.01';
use Data::Dumper;

use XSLoader;

XSLoader::load 'Object::with', $VERSION;


sub import {
    my $class = shift;
    my $pkg   = caller(0);
    no strict 'refs';
    *{"$pkg\::with"} = \&with;
}

our $TMP_OBJ;
my %TMP_METHOD_CACHE;

sub with ($&;@) { ## no critic
    local $TMP_OBJ    = shift;
    my $code          = shift;
    _with($code);

    my @ret = $code->(@_);

    while (my($name, $code) = each %TMP_METHOD_CACHE) {
        no strict 'refs';
        no warnings 'redefine';
        my($caller, $method) = $name =~ /^(.*)::(.*)$/;
        if ($code && ref $code) {
            *{$name} = $code;
        } else {
            *{$name} = sub{};
        }
        delete $TMP_METHOD_CACHE{$name};
    }

    _leave($code);

    @ret;
}

sub _entersub {
    return unless $TMP_OBJ;
    my $name    = shift;
    $name =~ s/^\*//;
    my($method) = $name =~ /^.*::(.*)$/;
    my $class   = ref($TMP_OBJ) || $TMP_OBJ;

    no strict 'refs';
    no warnings 'redefine';
    $TMP_METHOD_CACHE{$name} = defined &{$name} ? \&{$name} : undef unless exists $TMP_METHOD_CACHE{$name};
    *{$name}                 = sub { unshift @_, $TMP_OBJ; goto &{"$class\::$method"} };
}

1;
__END__

=encoding utf8

=head1 NAME

Object::with -

=head1 SYNOPSIS

  use Object::with;

=head1 DESCRIPTION

Object::with is

=head1 AUTHOR

Kazuhiro Osawa E<lt>ko@yappo.ne.jpE<gt>

=head1 SEE ALSO

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut