How do I implement dispatch tables in Perl?

I need to write a storage related app in Perl. The app needs to upload files from the local machine to some other storage nodes. Currently, the uploading method is FTP, but in the future it may be bittorrent or some unknown super-file-transferring method.

For every file that needs to be uploaded, there is a configuration file which defines the file name, the storage node which the file will be uploaded to and what transferring method should be used during the uploading.

Of course, I can use the following method to solve my problem:

{
  if ( $trans_type == "ftp" ) { ###FTP the FILE}
  if ( $trans_type == "bit" ) { ###BIT the FILE}
  ### etc ###
}

But even with my basic OO knowledge learned in school, I still feel that this is not a good design. (The question title might be a little bit misleading. If you think my problem can solved gracefully with a non-OO solution, it's quite OK for me. Actually it will be better, since I have limited OO knowledge.)

So could you guys give me some advice in general? Of course, if you provide some sample code as well, this will be a great help.

First, string equality testing in Perl is eq, not ==.

If you have methods to do the work, say named bit and ftp,

my %proc = (
    bit => \&bit,
    ftp => \&ftp,
);

my $proc = $proc{$trans_type};
$proc->() if defined $proc;

You can use a hash for this...

Have each transfer method register itself in the hash. You can do this OO (by calling a method on some transfer method factory) or procedurally (just make the hash a package variable, or you could even put it in the main package if you don't want to modularize).
```
package MyApp::Transfer::FTP;
$MyApp::TransferManager::METHODS{ftp} = \&do_ftp;
sub do_ftp { ... }
1;
```
Each transfer method uses a consistent API. Maybe its just it a function, or it could be an object interface.

Call the transfer through the hash.

sub do_transfer {
    # ...
    my $sub = $MyApp::TransferManager::METHODS{$method}
        or croak "Unknown transfer method $method";
    $sub->($arg1, $arg2, ...);
    # ...
}

BTW: The OO register method would look something like this:

package MyApp::TransferManager;
use Carp;
use strict;

my %registered_method;

sub register {
    my ($class, $method, $sub) = @_;

    exists $registered_method{$method}
        and croak "method $method already registered";

    $registered_method{$method} = $sub;
}

# ...

1;

(None of this code is tested; please forgive missing semicolons)

Chas. Owens

The correct design here is a factory. Take a look at how the DBI handles this. You will wind up with a TransferAgent class that instantiates one of any number of TransferAgent::* classes. Obviously you will want more error checking than the implementation below provides. Using a factory like this means that you can add new types of transfer agents without having to add or modify any code.

TransferAgent.pm - the factory class:

package TransferAgent;

use strict;
use warnings;

sub connect {
    my ($class, %args) = @_;

    require "$class/$args{type}.pm";

    my $ta = "${class}::$args{type}"->new(%args);
    return $ta->connect;
}

1;

TransferAgent/Base.pm - contains the base functionality of a TransferAgent::* class:

package TransferAgent::Base;

use strict;
use warnings;

use Carp;

sub new {
    my ($class, %self) = @_;
    $self{_files_transferred} = [];
    $self{_bytes_transferred} = 0;
    return bless \%self, $class;
}

sub files_sent { 
    return wantarray ?  @{$_[0]->{_files_sent}} : 
        scalar @{$_[0]->{_files_sent}};
}

sub files_received { 
    return wantarray ?  @{$_[0]->{_files_recv}} : 
        scalar @{$_[0]->{_files_recv}};
}

sub cwd    { return $_[0]->{_cwd}       }
sub status { return $_[0]->{_connected} }

sub _subname {
    return +(split "::", (caller 1)[3])[-1];
}

sub connect    { croak _subname, " is not implemented by ", ref $_[0] }
sub disconnect { croak _subname, " is not implemented by ", ref $_[0] }
sub chdir      { croak _subname, " is not implemented by ", ref $_[0] }
sub mode       { croak _subname, " is not implemented by ", ref $_[0] }
sub put        { croak _subname, " is not implemented by ", ref $_[0] }
sub get        { croak _subname, " is not implemented by ", ref $_[0] }
sub list       { croak _subname, " is not implemented by ", ref $_[0] }

1;

TransferAgent/FTP.pm - implements a (mock) FTP client:

package TransferAgent::FTP;

use strict;
use warnings;

use Carp;

use base "TransferAgent::Base";

our %modes = map { $_ => 1 } qw/ascii binary ebcdic/;

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new(@_);
    $self->{_mode} = "ascii";
    return $self;
}

sub connect    { 
    my $self = shift;
    #pretend to connect
    $self->{_connected} = 1;
    return $self;
}

sub disconnect {
    my $self = shift;
    #pretend to disconnect
    $self->{_connected} = 0;
    return $self;
}

sub chdir { 
    my $self = shift;
    #pretend to chdir
    $self->{_cwd} = shift;
    return $self;
}

sub mode {
    my ($self, $mode) = @_;

    if (defined $mode) {
        croak "'$mode' is not a valid mode"
            unless exists $modes{$mode};
        #pretend to change mode
        $self->{_mode} = $mode;
        return $self;
    }

    #return current mode
    return $self->{_mode};
}

sub put {
    my ($self, $file) = @_;
    #pretend to put file
    push @{$self->{_files_sent}}, $file;
    return $self;
}

sub get {
    my ($self, $file) = @_;
    #pretend to get file
    push @{$self->{_files_recv}}, $file;
    return $self;
}

sub list {
    my $self = shift;
    #pretend to list remote files
    return qw/foo bar baz quux/;
}

1;

script.pl - how to use TransferAgent:

#!/usr/bin/perl

use strict;
use warnings;

use TransferAgent;

my $ta = TransferAgent->connect(
    type     => "FTP",
    host     => "foo",
    user     => "bar",
    password => "baz",
);

print "files to get: ", join(", ", $ta->list), "\n";
for my $file ($ta->list) {
    $ta->get($file);
}
print "files gotten: ", join(", ", $ta->files_received), "\n";

$ta->disconnect;

I have several examples in Mastering Perl in the sections on dynamic subroutines.

See Implementing Dispatch Tables and MJD's treatment of dispatch tables in HOP.

OO would be overkill. My solution would probably look something like this:

sub ftp_transfer { ... }
sub bit_transfer { ... }
my $transfer_sub = { 'ftp' => \&ftp_transfer, 'bit' => \&bit_transfer, ... };
...
sub upload_file {
    my ($file, ...) = @_;
    ...
    $transfer_sub->{$file->{trans_type}}->(...);
}

You said initially it will use FTP and move to other transfer methods later. I wouldn't get "elegant" until you actually need to add the second or third technology. That second transfer method may never be required. :-)

If you want to do it as a "science project" then great.

I am tired of seeing OO design patterns complicating solutions to problems that never arrive.

Wrap the first transfer method in an uploadFile method. Add an if then else for the second method. Get elegant and refactor on the third method. By then you will have enough examples that your solution will probably be pretty generic.

Of course, my main point is that the second and third methods may never be required.

来源：https://stackoverflow.com/questions/1281456/how-do-i-implement-dispatch-tables-in-perl

标签

perl

dispatch-table