perl/Route.pm

   1 #!/usr/bin/perl
   2 #
   3 # This module impliments the abstracted routing for all protocols and
   4 # is probably what I SHOULD have done the first time.
   5 #
   6 # Heyho.
   7 #
   8 # This is just a container class which I expect to subclass
   9 #
  10 # Copyright (c) 2001 Dirk Koopman G1TLH
  11 #
  12 # $Id$
  13 #
  14
  15 package Route;
  16
  17 use DXDebug;
  18
  19 use strict;
  20
  21 use vars qw(%list %valid);
  22
  23 %valid = (
  24                   call => "0,Callsign",
  25                  );
  26
  27 sub new
  28 {
  29         my ($pkg, $call) = @_;
  30         dbg('route', "$pkg created $call");
  31         return bless {call => $call}, $pkg;
  32 }
  33
  34 #
  35 # get a callsign from a passed reference or a string
  36 #
  37
  38 sub _getcall
  39 {
  40         my $self = shift;
  41         my $thingy = shift;
  42         $thingy = $self unless $thingy;
  43         $thingy = $thingy->call if ref $thingy;
  44         $thingy = uc $thingy if $thingy;
  45         return $thingy;
  46 }
  47
  48 #
  49 # add and delete a callsign to/from a list
  50 #
  51
  52 sub _addlist
  53 {
  54         my $self = shift;
  55         my $field = shift;
  56         foreach my $c (@_) {
  57                 my $call = _getcall($c);
  58                 unless (grep {$_ eq $call} @{$self->{$field}}) {
  59                         push @{$self->{$field}}, $call;
  60                         dbg('route', ref($self) . " adding $call to " . $self->{call} . "->\{$field\}");
  61                 }
  62         }
  63 }
  64
  65 sub _dellist
  66 {
  67         my $self = shift;
  68         my $field = shift;
  69         foreach my $c (@_) {
  70                 my $call = _getcall($c);
  71                 if (grep {$_ eq $call} @{$self->{$field}}) {
  72                         $self->{$field} = [ grep {$_ ne $call} @{$self->{$field}} ];
  73                         dbg('route', ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}");
  74                 }
  75         }
  76 }
  77
  78 #
  79 # track destruction
  80 #
  81
  82 sub DESTROY
  83 {
  84         my $self = shift;
  85         my $pkg = ref $self;
  86
  87         dbg('route', "$pkg $self->{call} destroyed");
  88 }
  89
  90 no strict;
  91 #
  92 # return a list of valid elements
  93 #
  94
  95 sub fields
  96 {
  97         my $pkg = shift;
  98         my @out, keys %pkg::valid if ref $pkg;
  99         push @out, keys %valid;
 100         return @out;
 101 }
 102
 103 #
 104 # return a prompt for a field
 105 #
 106
 107 sub field_prompt
 108 {
 109         my ($self, $ele) = @_;
 110         my $pkg = ref $self;
 111         return $pkg::valid{$ele} || $valid{$ele};
 112 }
 113
 114 #
 115 # generic AUTOLOAD for accessors
 116 #
 117 sub AUTOLOAD
 118 {
 119         my $self = shift;
 120         my ($pkg, $name) = $AUTOLOAD =~ /^(.*)::([^:]*)$/;
 121         return if $name eq 'DESTROY';
 122
 123         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $pkg::valid{$name};
 124
 125         # this clever line of code creates a subroutine which takes over from autoload
 126         # from OO Perl - Conway
 127         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
 128     @_ ? $self->{$name} = shift : $self->{$name} ;
 129 }
 130
 131 1;