Evolution of OOP: mro for EVERY::LAST one of us!

The evolution of Object-Oriented Perl has gone through a number of stages. An early advance was NEXT, which gave optional re-dispatch and the pseudo-classes EVERY & EVERY::LAST to dispatch up and down the stack automatically. Then mro() came along and offered improved method dispatch, but left out the pseudo-classes. This talk describes adding a role to mro::EVERY to add the pseudo-classes and also how to hack mro() into NEXT in a backwards compatible way.

Transcript

1. Evolution of OOP:
   mro for EVERY::LAST one of us!
   Steven Lembark
   Workhorse Computing
   lembark@wrkhors.com
   

   View Slide

2. OOP is not an oxymoron.
   Conway’s Object Oriented Programming.
   Perl’s OO is flexible, adaptable.
   Allowed 20+ years of advances.
   

   View Slide

3. OOP is not an oxymoron.
   Conway’s Object Oriented Programming.
   Perl’s OO is flexible, adaptable.
   Allowed 20+ years of advances.
   Largely through evolution.
   

   View Slide

4. Example: NEXT
   NEXT::Foo
   SUPER with logic
   EVERY::foo
   EVERY::LAST::foo
   Destructor & Constructor chaining.
   Redispatch down and up the chain is automagical.
   

   View Slide

5. EVERY::LAST
   Lazyness: Do something once.
   Perly ‘new’ is generic:
   sub new
   {
   my $proto = shift;
   my $obj = $proto->construct;
   $obj->EVERY::LAST::initialize( @_ );
   $obj
   }
   

   View Slide

6. EVERY::LAST
   Lazyness: Do something once.
   Initializers don’t have to daisy-chain.
   sub new
   {
   my $proto = shift;
   my $obj = $proto->construct;
   $obj->EVERY::LAST::initialize( @_ );
   $obj
   }
   

   View Slide

7. EVERY
   Lazyness: Do something once.
   Neither do destructors.
   DESTROY
   {
   my $obj = shift;
   $obj->EVERY::cleanup;
   $obj
   }
   

   View Slide

8. Evolution: mro
   Offers “c3” instead of depth-first search.
   Saner, more predictable.
   Whole lot faster than NEXT.
   

   View Slide

9. mro lacks EVERY & EVERY::LAST
   It does have “maybe_next”.
   Requires explicit daisy chain:
   sub initialize
   {
   my $obj = shift;
   ...
   $obj->mro::maybe_next
   }
   

   View Slide

10. Fix:
    Hubris
    

    View Slide

11. Fix: mro::EVERY
    Installs two pseudo-classes:
    EVERY
    EVERY::LAST
    Dispatch down/up the inheritence tree.
    Order defined by mro.
    

    View Slide

12. Fix one: mro::EVERY
    package Frobnicate;
    use mro::EVERY;
    sub new
    {
    my $frob = &construct;
    $frob->EVERY::LAST::initialize( @_ );
    $frob
    }
    Looks like NEXT.
    

    View Slide

13. Fix one: mro::EVERY
    Q: How to redispatch random subs?
    

    View Slide

14. Fix one: mro::EVERY
    Q: How to redispatch random subs?
    A: The magic of AUTOLOAD.
    

    View Slide

15. Fix one: mro::EVERY
    Q: How to redispatch random subs?
    A: The magic of AUTOLOAD.
    PBP be damned...
    

    View Slide

16. Start with mro
    mro::get_linear_isa
    Resolves package “isa”.
    Uses depth-first or “c3”.
    

    View Slide

17. AUTOLOAD does the dispatch
    $foo->EVERY::bar( @blort );
    package EVERY;
    our $AUTOLOAD = ‘’;
    sub AUTOLOAD
    {
    my ( $name ) = $AUTOLOAD =~ m{ (\w+) $}x;
    my $proto = shift;
    for my $pkg ( $proto->mro::get_linear_isa->@* )
    ...
    }
    

    View Slide

18. AUTOLOAD does the dispatch
    $foo->EVERY::bar( @blort );
    package EVERY;
    our $AUTOLOAD = ‘’;
    sub AUTOLOAD
    {
    my ( $name ) = $AUTOLOAD = m{ (\w+) $}x;
    my $proto = shift;
    for my $pkg ( $proto->mro::get_linear_isa->@* )
    ...
    }
    

    View Slide

19. AUTOLOAD does the dispatch
    $foo->EVERY::bar( @blort );
    package EVERY;
    our $AUTOLOAD = ‘EVERY::bar’;
    sub AUTOLOAD
    {
    my ( $name ) = $AUTOLOAD = m{ (\w+) $}x;
    my $proto = shift;
    for my $pkg ( $proto->mro::get_linear_isa->@* )
    ...
    }
    

    View Slide

20. AUTOLOAD does the dispatch
    $foo->EVERY::bar( @blort );
    package EVERY;
    our $AUTOLOAD = ‘’;
    sub AUTOLOAD
    {
    my ( $name ) = $AUTOLOAD = m{ (\w+) $}x;
    my $proto = shift;
    for my $pkg ( $proto->mro::get_linear_isa->@* )
    ...
    }
    

    View Slide

21. AUTOLOAD does the dispatch
    $foo->EVERY::bar( @blort );
    package EVERY;
    our $AUTOLOAD = ‘’;
    sub AUTOLOAD
    {
    my ( $name ) = $AUTOLOAD = m{ (\w+) $}x;
    my $proto = shift;
    for my $pkg ( $proto->mro::get_linear_isa->@* )
    ...
    }
    

    View Slide

22. AUTOLOAD does the dispatch
    $foo->EVERY::bar( @blort );
    package EVERY;
    our $AUTOLOAD = ‘’;
    sub AUTOLOAD
    {
    my ( $name ) = $AUTOLOAD = m{ (\w+) $}x;
    my $proto = shift;
    for my $pkg ( $proto->mro::get_linear_isa->@* )
    ...
    }
    

    View Slide

23. Finding a method
    Most common way to look: can().
    for my $pkg ( $class->mro::get_linear_isa->@* )
    {
    my $sub = $pkg->can( $name )
    or next;
    ...
    }
    

    View Slide

24. Finding a method
    Returns inherited $name, not declared.
    for my $pkg ( $class->mro::get_linear_isa->@* )
    {
    my $sub = $pkg->can( $name )
    or next;
    ...
    }
    

    View Slide

25. Finding a method
    Symbol::qualify_to_ref.
    for my $pkg ( $class->mro::get_linear_isa->@* )
    {
    my $sub = *{ qualify_to_ref $name => $pkg }{ CODE }
    or next;
    ...
    }
    

    View Slide

26. Finding a method
    Subref when it’s defined in the package.
    for my $pkg ( $class->mro::get_linear_isa->@* )
    {
    my $sub = *{ qualify_to_ref $name => $pkg }{ CODE }
    or next;
    ...
    }
    

    View Slide

27. Redispatching a method.
    Perl has first-class subs.
    for my $pkg ( $class->mro::get_linear_isa->@* )
    {
    my $sub = *{ qualify_to_ref $name => $pkg }{ CODE }
    or next;
    $proto->$sub( @_ );
    }
    

    View Slide

28. Redispatching a method.
    Doesn’t handle AUTOLOAD!
    for my $pkg ( $class->mro::get_linear_isa->@* )
    {
    my $sub = *{ qualify_to_ref $name => $pkg }{ CODE }
    or next;
    $proto->$sub( @_ );
    }
    

    View Slide

29. EVERY::LAST dispatchs up the tree
    Not much difference:
    for my $pkg ( reverse $class->mro::get_linear_isa->@* )
    {
    my $sub = *{ qualify_to_ref $name => $pkg }{ CODE }
    or next;
    ...
    }
    for my $pkg ( reverse $class->mro::get_linear_isa->@* )
    {
    my $sub = *{ qualify_to_ref $name => $pkg }{ CODE }
    or next;
    ...
    }
    

    View Slide

30. Avoiding “Red Flags”
    Cut+Paste is a mistake.
    

    View Slide

31. Avoiding “Red Flags”
    my $methodology
    = sub
    {
    my ( $proto, $name ) = @_;
    map
    {
    *{ qualify_to_ref $name => $_ }{ CODE } // ()
    }
    $proto->mro::get_linear_isa->@*
    };
    Package the re-usable portion in a utility sub.
    

    View Slide

32. Avoiding “Red Flags”
    package EVERY;
    our $AUTOLOAD = ‘’;
    sub AUTOLOAD
    {
    my $proto = shift;
    my $name = ( split ‘::’, $AUTOLOAD )[-1];
    $proto->$_( @_ )
    for uniq $methodology->($proto, $name)
    }
    List of subs in mro-order.
    

    View Slide

33. Avoiding “Red Flags”
    package EVERY::LAST;
    our $AUTOLOAD = ‘’;
    sub AUTOLOAD
    {
    my $proto = shift;
    my $name = ( split ‘::’, $AUTOLOAD )[-1];
    $proto->$_( @_ )
    for uniq reverse $methodology->($proto, $name)
    }
    Reverse the order for Every::Last
    

    View Slide

34. Avoiding “Red Flags”
    for uniq $methodology->($proto, $name);
    for uniq reverse $methodology->($proto, $name);
    

    View Slide

35. Avoiding “Red Flags”
    Avoid re-dispatching identical methods.
    use Foo qw( bar );
    Only want to dispatch it once.
    for uniq $methodology->($proto, $name);
    for uniq reverse $methodology->($proto, $name);
    

    View Slide

36. Avoiding “Red Flags”
    EVERY uses most-derived.
    First defined method looking down the tree.
    Useful for destructors peeling off layers.
    EVERY::LAST uses least-derived.
    Constructor-ish code handled by base classes.
    for uniq $methodology->($proto, $name);
    for uniq reverse $methodology->($proto, $name);
    

    View Slide

37. Handling AUTOLOAD
    What if the package doesn’t define $name?
    Uses its own AUTOLOAD instead?
    # $name isn’t AUTOLOAD!
    *{ qualify_to_ref $name => $_ }{ CODE } // ()
    

    View Slide

38. Handling AUTOLOAD
    Requires an co-operating ‘can’ operator.
    More expsive: you have to ask for it.
    use mro::EVERY qw( autoload );
    *{ qualify_to_ref $name => $_ }{ CODE }
    or
    do
    {
    ...
    }
    

    View Slide

39. Doing the can can()
    package Yours;
    our $AUTOLOAD = ‘’;
    sub AUTOLOAD { … }
    my @names = qw( this that other );
    my %auto_can = map { ( $_ => \&AUTOLOAD ) } @names;
    sub can
    {
    my ( $proto, $name ) = @_;
    $proto->can( $name ) or $auto_can{ $name }
    }
    

    View Slide

40. Doing the can can()
    package Yours;
    our $AUTOLOAD = ‘’;
    sub AUTOLOAD { … }
    my @names = qw( this that other );
    my %auto_can = map { ( $_ => \&AUTOLOAD ) } @names;
    sub can
    {
    my ( $proto, $name ) = @_;
    $proto->can( $name ) or $auto_can{ $name }
    }
    

    View Slide

41. Doing the can can()
    package Yours;
    our $AUTOLOAD = ‘’;
    sub AUTOLOAD { … }
    my @names = qw( this that other );
    my %auto_can = map { ( $_ => \&AUTOLOAD ) } @names;
    sub can
    {
    my ( $proto, $name ) = @_;
    $proto->can( $name ) or $auto_can{ $name }
    }
    

    View Slide

42. Doing the can can()
    package Yours;
    our $AUTOLOAD = ‘’;
    sub AUTOLOAD { … }
    my @names = qw( this that other );
    my %auto_can = map { ( $_ => \&AUTOLOAD ) } @names;
    sub can
    {
    my ( $proto, $name ) = @_;
    $proto->can( $name ) or $auto_can{ $name }
    }
    

    View Slide

43. map
    {
    *{ qualify_to_ref $name, $_ }{CODE}
    or do
    {
    local *{qualify_to_ref ISA => $_} = [];
    $_->can( $name )
    ? $name
    : ()
    }
    }
    $proto->mro::get_linear_isa->@*;
    Dispatching AUTOLOAD
    

    View Slide

44. map
    {
    *{ qualify_to_ref $name, $_ }{CODE}
    or do
    {
    local *{qualify_to_ref ISA => $_} = [];
    $_->can( $name )
    ? $name
    : ()
    }
    }
    $proto->mro::get_linear_isa->@*;
    Dispatching AUTOLOAD
    

    View Slide

45. map
    {
    *{ qualify_to_ref $name, $_ }{CODE}
    or do
    {
    local *{qualify_to_ref ISA => $_} = [];
    $_->can( $name )
    ? $name
    : ()
    }
    }
    $proto->mro::get_linear_isa->@*;
    Dispatching AUTOLOAD
    

    View Slide

46. Dispatching AUTOLOAD
    Yes, $name isn’t qualified.
    Required for Perl to set $AUTOLOAD.
    Point of AUTOLOAD is a catch-all.
    Stacked AUTOLOAD calls are rare.
    

    View Slide

47. Dispatching AUTOLOAD
    Alternative: dispatch with a closure.
    Pre-load $AUTOLOAD with qualify_to_ref.
    Dispatch via subref.
    

    View Slide

48. Dispatching AUTOLOAD
    if( my $sub = $_->can( $name ) )
    {
    my $ref = qualify_to_ref AUTOLOAD => $_;
    sub
    {
    *$ref = \$name;
    goto &$sub;
    }
    ...
    

    View Slide

49. Module is small
    Main package is just a pair of maps.
    Pseudo-classes are just a pair of AUTOLOADS.
    

    View Slide

50. Fix two:
    Lots of Hubris...
    

    View Slide

51. Fix two:
    Hack NEXT.
    

    View Slide

52. Fix two:
    Replace method lookup with mro.
    Replace “ref $x” with “blessed $x” for object tests.
    Replace “no strict” with qualify_to_ref...
    

    View Slide

53. Into the nextaverse
    Two subs do the dirty work:
    NEXT::ELSEWHERE::ancestors
    NEXT::ELSEWHERE::ordered_ancestors
    

    View Slide

54. Into the nextaverse
    Two subs do the dirty work:
    NEXT::ELSEWHERE::ancestors
    Depth-first-search in Pure Perl.
    NEXT::ELSEWHERE::ordered_ancestors
    c3[ish] in Pure Perl.
    

    View Slide

55. DFS in Pure Perl
    Iterate @ISA chains with symbolic refs.
    sub NEXT::ELSEWHERE::ancestors
    {
    my @inlist = shift;
    my @outlist = ();
    while (my $next = shift @inlist) {
    push @outlist, $next;
    no strict 'refs';
    unshift @inlist, @{"$outlist[-1]::ISA"};
    }
    return @outlist;
    }
    

    View Slide

56. DFS in Pure Perl
    Using mro
    sub NEXT::ELSEWHERE::ancestors
    {
    my $proto = shift;
    @{ $proto->mro::get_linear_isa( ‘dfs’ ) }
    }
    

    View Slide

57. DFS in Pure Perl
    Using object syntax
    sub NEXT::ELSEWHERE::ancestors
    {
    my $proto = shift;
    $proto->mro::get_linear_isa( ‘dfs’ )->@*
    }
    

    View Slide

58. Purly Perly c3[ish]
    sub NEXT::ELSEWHERE::ordered_ancestors
    {
    my @inlist = shift;
    my @outlist = ();
    while (my $next = shift @inlist) {
    push @outlist, $next;
    no strict 'refs';
    push @inlist, @{"$outlist[-1]::ISA"};
    }
    return sort { $a->isa($b) ? -1
    : $b->isa($a) ? +1
    : 0 } @outlist;
    }
    

    View Slide

59. Purly Perly c3[ish]
    sub NEXT::ELSEWHERE::ordered_ancestors
    {
    my $proto = shift;
    $proto->mro::get_linear_isa->( ‘c3’ )->@*
    }
    

    View Slide

60. Purly Perly c3[ish]
    sub NEXT::ELSEWHERE::ordered_ancestors
    {
    my $proto = shift;
    $proto->mro::get_linear_isa->( ‘c3’ )->@*
    }
    Well, Almost:
    OA sorts depth-first, then left-most.
    C3 sorts left-most, then depth-first.
    Both constrain derived classes to precede base classes.
    

    View Slide

61. EVERY vs. EVERY::LAST
    NEXT uses ancestors().
    EVERY & EVERY::LAST use ordered_ancestors().
    NEXT => mro( ‘dfs’ )
    EVERY => mro( ‘c3’ )
    Ideally both use mro from classes.
    

    View Slide

62. Fix for backwards uses
    use NEXT qw( :backwards );
    dfs in NEXT, c3 in EVERY.
    Without it we use class specification in both.
    

    View Slide

63. Fix for backwards uses
    my %backwards = ();
    sub import
    {
    my $caller = caller;
    for( @_ )
    {
    if( m{ :backwards } )
    {
    $backwards{ $caller } = undef;
    }
    }
    }
    

    View Slide

64. Fix for backwards uses
    sub NEXT::ELSEWHERE::ancestors
    {
    my $proto = shift;
    exists $backwards{ blessed $proto }
    ? $proto->mro::get_linear_isa->( 'dfs' )->@*
    : $proto->mro::get_linear_isa->@*
    }
    

    View Slide

65. So what? It isn’t written in 5.8.8
    Core modules have to be consistent.
    Doesn’t mean they can’t evolve.
    

    View Slide

66. So what? It isn’t written in 5.8.8
    Provide people what they want:
    5.8 users get a 5.8 module.
    Later users get a later module.
    Bugs can be fixed everywhere.
    Features get added to the more recent versions.
    

    View Slide

67. So what? It isn’t written in 5.8.8
    Handled in Makfile.PL:
    Install first directory <= $^V
    with File::Copy::Recursive.
    Added to FindBin:libs in 5.14.
    NEXT-x.y.z
    Makefile.PL
    version
    v5.8.8
    lib
    NEXT.pm
    t
    ...
    v5.10
    lib
    NEXT.pm # mro
    t
    ...
    v5.24
    lib
    NEXT.pm # ->@*
    t
    

    View Slide

68. Yes, there is more than one way
    Layering EVERY onto mro isn’t difficult.
    Inserting mro() into NEXT isn’t that hard either.
    Advancing modules with Perl is doable.
    

    View Slide

69. References
    https://metacpan.org/pod/NEXT
    https://metacpan.org/pod/mro::EVERY
    Handling multiple versions:
    https://metacpan.org/release/LEMBARK/FindBin-libs-
    v3.0.1/source/Makefile.PL#L63
    https://metacpan.org/pod/Module::FromPerlVer
    

    View Slide