Roll-your-own OO system with Closures and a Dispatch Table

Okay… this isn’t an article or an essay… just more rambling notes from a random guy working on learning Perl. This is not a plea for help, so don’t feel like you have to jump in and rescue me or anything. I should develop my ideas further before posting, but I figure I’ll quit working on this if I “go dark” too soon.

I write these little programs and then I try to turn them into classes and try to instantiate them. Somehow, I don’t understand references, variable scope, and packages well enough to grok why I’m falling on my face here. (I remember a few years ago trying to read an early edition of Learning Perl and giving up pretty fast. Programming Perl was just plain frightening then. I can understand a lot more of it now, but I still get lost when I try to apply it.) I’m mad enough at the OO system that I’m willing to roll my own just to avoid the issue: I’d rather have a system that I understand completely than use one that’s much more robust but that does things that seem weird or wrong to me. Of course, I’d sacrifice some much-needed compiler help in the process, by there you go…. I have played with Moose, but my standard brain-dead OO use case that I want to roll with isn’t in their recipe list. It’s probably there somewhere, but I’ve used it enough that I know I need to understand more about regular Perl OO to use it—just so I can pick up the syntax and know what’s going on under the hood.

In any case… my view of objects may be shifting. I don’t know. I think an object should be completely malleable at runtime. I want to be able to add and remove properties and methods at will. Reflection should be drop-dead easy. Maybe I want to reinvent Smalltalk or something, I don’t know…. For some reason this just seems too hard to me in most OO systems. There’s probably some technical reason for this– or maybe I’m just lazy. Who cares. Meh.

In my last bit of Perl code, I had a table object glommed in with the rest of my code—it’s just crying to be abstracted out. I use dispatch tables all the time now, so a dispatch table class seems like a good idea. How many times do I need to cut and paste that code before I roll it into a module file?? And finally, we have the beginnings of the widget that I’m sketching out below. (Yep… totally done with closures—fun, fun, fun! For some reason I couldn’t figure out how to pass arguments to the dispatch table subs. I spent hours messing with it and I just don’t understand why I couldn’t. That’s why it’s using lame global variables in there for that….) At any rate, if I thought I could just pick up the Perl OO system and just run with it, I was wrong.

Time to sit down and RTFM– back to Programming Perl and Intermediate Perl for the time being…. Then we can revisit class definitions for data tables, widgets, dispatch tables, and my parser if I don’t come to my senses by then….

#!/usr/bin/perl
use warnings;
use strict;
my $show_debug = 0;

my @current_arguments;
my $current_stuff;

my %dispatch_data = (

    'Create Field'  => {
        code    => sub {  my ($field, $regex, $default) = @current_arguments;
                          $current_stuff->{$field} = create_field($regex, $default);
                          return $current_stuff->{$field};
                       },
        debug   => sub { print "Create Field called\n" },
    }

    );

my $dispatch_table = {};
while ( my ( $command, $dispatch ) = each %dispatch_data ) {
    $dispatch_table->{ $command } = sub {
        $dispatch->{ code  }->()  if exists $dispatch->{ code };
        $dispatch->{ debug }->()  if $show_debug;
    } if exists $dispatch->{ code } or ($show_debug and exists $dispatch->{ debug });
}

### return a closure that handles get and set methods for the field
sub create_field {
    my ($regex, $default) = @_;
    my $value;
    $value = $default if $default;
    return sub { my ($v) = @_;
                 if ($v) {
		     if ($regex) {
			 die "Value $v does not match |$regex|." unless ($v =~ /^$regex$/);
		     }
		     $value = $v;
                     return $value;
		 } else {
		     return $value;
		 }
               };
}

sub create_widget {
    my %stuff;
    return sub { my $command = shift;
                 if ($dispatch_table->{$command}) {
                     @current_arguments = @_;
                     $current_stuff = \%stuff;
                     return $dispatch_table->{$command}->();
                 } else {
                     my $thing = $stuff{$command};
                     die "No such thing '$command' in our stuff!" unless $thing;
                     my ($field, $value) = @_;
                     return $thing->($field, $value);
                 }
               };
}

my $f = create_field('\d+');
my $x = $f->(42);
$f->(77);
my $y = $f->();
print "x is $x and y is $y\n";

my $w = create_widget();
$w->('Create Field', 'Prop', '\d+', 43);
my $z = $w->('Prop');
$w->('Prop', 78);
my $a = $w->('Prop');
print "z is $z and a is $a";