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                   flags => "0,Flags,phex",
  26                  );
  27
  28 sub new
  29 {
  30         my ($pkg, $call) = @_;
  31
  32         dbg('routelow', "create " . (ref($pkg) || $pkg) ." with $call");
  33
  34         return bless {call => $call}, (ref $pkg || $pkg);
  35 }
  36
  37 #
  38 # get a callsign from a passed reference or a string
  39 #
  40
  41 sub _getcall
  42 {
  43         my $self = shift;
  44         my $thingy = shift;
  45         $thingy = $self unless $thingy;
  46         $thingy = $thingy->call if ref $thingy;
  47         $thingy = uc $thingy if $thingy;
  48         return $thingy;
  49 }
  50
  51 #
  52 # add and delete a callsign to/from a list
  53 #
  54
  55 sub _addlist
  56 {
  57         my $self = shift;
  58         my $field = shift;
  59         foreach my $c (@_) {
  60                 my $call = _getcall($c);
  61                 unless (grep {$_ eq $call} @{$self->{$field}}) {
  62                         push @{$self->{$field}}, $call;
  63                         dbg('routelow', ref($self) . " adding $call to " . $self->{call} . "->\{$field\}");
  64                 }
  65         }
  66         return $self->{$field};
  67 }
  68
  69 sub _dellist
  70 {
  71         my $self = shift;
  72         my $field = shift;
  73         foreach my $c (@_) {
  74                 my $call = _getcall($c);
  75                 if (grep {$_ eq $call} @{$self->{$field}}) {
  76                         $self->{$field} = [ grep {$_ ne $call} @{$self->{$field}} ];
  77                         dbg('routelow', ref($self) . " deleting $call from " . $self->{call} . "->\{$field\}");
  78                 }
  79         }
  80         return $self->{$field};
  81 }
  82
  83 #
  84 # flag field constructors/enquirers
  85 #
  86
  87 sub here
  88 {
  89         my $self = shift;
  90         my $r = shift;
  91         return $self ? 2 : 0 unless ref $self;
  92         return $self->{flags} & 2 unless $r;
  93         $self->{flags} = (($self->{flags} & ~2) | ($r ? 2 : 0));
  94         return $r;
  95 }
  96
  97 sub conf
  98 {
  99         my $self = shift;
 100         my $r = shift;
 101         return $self ? 1 : 0 unless ref $self;
 102         return $self->{flags} & 1 unless $r;
 103         $self->{flags} = (($self->{flags} & ~1) | ($r ? 1 : 0));
 104         return $r;
 105 }
 106
 107 #
 108 # display routines
 109 #
 110
 111 sub user_call
 112 {
 113         my $self = shift;
 114         my $call = sprintf "%s", $self->{call};
 115         return $self->here ? "$call" : "($call)";
 116 }
 117
 118 sub config
 119 {
 120         my $self = shift;
 121         my $nodes_only = shift;
 122         my $level = shift;
 123         my @out;
 124         my $line;
 125         my $call = $self->user_call;
 126
 127         $line = ' ' x ($level*2) . "$call";
 128         $call = ' ' x length $call;
 129         unless ($nodes_only) {
 130                 if (@{$self->{users}}) {
 131                         $line .= '->';
 132                         foreach my $ucall (sort @{$self->{users}}) {
 133                                 my $uref = Route::User::get($ucall);
 134                                 my $c;
 135                                 if ($uref) {
 136                                         $c = $uref->user_call;
 137                                 } else {
 138                                         $c = "$ucall?";
 139                                 }
 140                                 if ((length $line) + (length $c) + 1 < 79) {
 141                                         $line .= $c . ' ';
 142                                 } else {
 143                                         $line =~ s/\s+$//;
 144                                         push @out, $line;
 145                                         $line = ' ' x ($level*2) . "$call->";
 146                                 }
 147                         }
 148                 }
 149         }
 150         $line =~ s/->$//g;
 151         $line =~ s/\s+$//;
 152         push @out, $line if length $line;
 153
 154         foreach my $ncall (sort @{$self->{nodes}}) {
 155                 my $nref = Route::Node::get($ncall);
 156                 next if @_ && !grep $ncall =~ m|$_|, @_;
 157
 158                 if ($nref) {
 159                         my $c = $nref->user_call;
 160                         push @out, $nref->config($nodes_only, $level+1, @_);
 161                 } else {
 162                         push @out, ' ' x (($level+1)*2)  . "$ncall?";
 163                 }
 164         }
 165
 166         return @out;
 167 }
 168
 169 #
 170 # track destruction
 171 #
 172
 173 sub DESTROY
 174 {
 175         my $self = shift;
 176         my $pkg = ref $self;
 177
 178         dbg('routelow', "$pkg $self->{call} destroyed");
 179 }
 180
 181 no strict;
 182 #
 183 # return a list of valid elements
 184 #
 185
 186 sub fields
 187 {
 188         my $pkg = shift;
 189         $pkg = ref $pkg if ref $pkg;
 190         my @out, keys %$pkg::valid;
 191         push @out, keys %valid;
 192         return @out;
 193 }
 194
 195 #
 196 # return a prompt for a field
 197 #
 198
 199 sub field_prompt
 200 {
 201         my ($self, $ele) = @_;
 202         my $pkg = ref $self;
 203         return $pkg::valid{$ele} || $valid{$ele};
 204 }
 205
 206 #
 207 # generic AUTOLOAD for accessors
 208 #
 209 sub AUTOLOAD
 210 {
 211         my $self = shift;
 212         my $name = $AUTOLOAD;
 213         return if $name =~ /::DESTROY$/;
 214         $name =~ s/.*:://o;
 215
 216         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 217
 218         # this clever line of code creates a subroutine which takes over from autoload
 219         # from OO Perl - Conway
 220 #       *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
 221     @_ ? $self->{$name} = shift : $self->{$name} ;
 222 }
 223
 224 1;