Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

original.pm

by miyagawa (Chaplain)
on Jan 11, 2002 at 19:09 UTC ( #138020=perlmeditation: print w/ replies, xml ) Need Help??

There's a reseach going, for "Difference based module programming", which may be something related with Aspect Oriented Programming a bit.

First, you should read http://staff.aist.go.jp/y-ichisugi/mj/ for details of this programming paradigm.

OK?

Now here's an implementation of original.pm, MixJuice in Perl. Any suggestions welcome. Tarball can be downloaded from http://bulknews.net/lib/archives/original-0.01.tar.gz.

package original; use strict; use vars qw($VERSION); $VERSION = 0.01; my %Registered; sub import { my($class, $orig) = @_; my $pkg = caller; no strict 'refs'; *{"$pkg\::import"} = sub { return if exists $Registered{$pkg}; local $SIG{__WARN__} = sub {}; for my $method (__find_methods($pkg)) { next if $method eq 'import'; if (defined &{"$orig\::$method"}) { $Registered{$pkg}{$method} = \&{"$orig\::$method"}; } *{"$orig\::$method"} = \&{"$pkg\::$method"}; } }; *{"$pkg\::original"} = \&original; } sub __find_methods { my $class = shift; no strict 'refs'; my $globhash = "$class\::"; return grep { $globhash->{$_} and *{$globhash->{$_}}{CODE}; } keys %$globhash; } sub original { (my $meth = (caller(1))[3]) =~ s/.*:://; no strict 'refs'; goto &{"ORIGINAL::$meth"}; } package ORIGINAL; use vars qw($AUTOLOAD); sub AUTOLOAD { my $pkg = caller; (my $meth = $AUTOLOAD) =~ s/.*:://; my $orig = $Registered{$pkg}{$meth}; goto &$orig; } 1; __END__ =head1 NAME original - MixJuice in Perl =head1 SYNOPSIS package Animal; sub new { my($class, $hashref) = @_; bless {%$hashref}, $class; } package Animal::Speak; use original 'Animal'; sub speak { my $self = shift; return "My name is $self->{name}"; } package Animal::Dog; use original 'Animal'; sub bark { return 'bow wow'; } sub speak { my $self = shift; if ($self->{name} eq 'Snoopy') { return "Snoopy is $self->{name}"; } $self->ORIGINAL::speak(@_); # or $self->original(@_); } # Then, in a main script! use Animal; use Animal::Speak; my $spot = Animal->new({ name => 'Spot' }); print $spot->speak; # 'My name is Spot'; use Animal::Dog; my $snoopy = Animal->new({ name => 'Snoopy' }); print $snoopy->bark; # 'bow wow'; print $snoopy->speak; # 'Snoopy is Snoopy'; =head1 DESCRIPTION original.pm is a proof-of-concept implemetation of MixJuice, in Perl. See http://staff.aist.go.jp/y-ichisugi/mj/ for details :) =head1 AUTHOR Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt> This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO http://www.ogis-ri.co.jp/otc/hiroba/technical/MixJuice/, L<NEXT>, L<Exporter::Lite>, L<Class::Virtually::Abstract> =cut

--
Tatsuhiko Miyagawa
miyagawa@cpan.org

Comment on original.pm
Download Code
Re: original.pm
by IlyaM (Parson) on Jan 14, 2002 at 20:38 UTC
    You have triggered my curiosity. Why do you have
    local $SIG{__WARN__} = sub {};
    in import? Why not just
    local $^W = 0; # or even [no warnings 'redefine'] if you don't mind # restricting module to perl 5.6.0+
    ?

    --
    Ilya Martynov (http://martynov.org/)

      You're right. $SIG{__WARN__} stuff may be a leftover of my catching of WARN and DIE in debugging.

      Thanks.

      --
      Tatsuhiko Miyagawa
      miyagawa@cpan.org

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlmeditation [id://138020]
Approved by root
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others contemplating the Monastery: (7)
As of 2015-07-06 16:33 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (77 votes), past polls