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         my $printit = 1;
 127
 128         # allow ranges
 129         if (@_) {
 130                 $printit = grep $call =~ m|$_|, @_;
 131         }
 132
 133         if ($printit) {
 134                 $line = ' ' x ($level*2) . "$call";
 135                 $call = ' ' x length $call;
 136                 unless ($nodes_only) {
 137                         if (@{$self->{users}}) {
 138                                 $line .= '->';
 139                                 foreach my $ucall (sort @{$self->{users}}) {
 140                                         my $uref = Route::User::get($ucall);
 141                                         my $c;
 142                                         if ($uref) {
 143                                                 $c = $uref->user_call;
 144                                         } else {
 145                                                 $c = "$ucall?";
 146                                         }
 147                                         if ((length $line) + (length $c) + 1 < 79) {
 148                                                 $line .= $c . ' ';
 149                                         } else {
 150                                                 $line =~ s/\s+$//;
 151                                                 push @out, $line;
 152                                                 $line = ' ' x ($level*2) . "$call->";
 153                                         }
 154                                 }
 155                         }
 156                 }
 157                 $line =~ s/->$//g;
 158                 $line =~ s/\s+$//;
 159                 push @out, $line if length $line;
 160         }
 161
 162         foreach my $ncall (sort @{$self->{nodes}}) {
 163                 my $nref = Route::Node::get($ncall);
 164
 165                 if ($nref) {
 166                         my $c = $nref->user_call;
 167                         push @out, $nref->config($nodes_only, $level+1, @_);
 168                 } else {
 169                         push @out, ' ' x (($level+1)*2)  . "$ncall?" if @_ == 0 || (@_ && grep $ncall =~ m|$_|, @_);
 170                 }
 171         }
 172
 173         return @out;
 174 }
 175
 176 #
 177 # routing things
 178 #
 179
 180
 181 #
 182 # track destruction
 183 #
 184
 185 sub DESTROY
 186 {
 187         my $self = shift;
 188         my $pkg = ref $self;
 189
 190         dbg('routelow', "$pkg $self->{call} destroyed");
 191 }
 192
 193 no strict;
 194 #
 195 # return a list of valid elements
 196 #
 197
 198 sub fields
 199 {
 200         my $pkg = shift;
 201         $pkg = ref $pkg if ref $pkg;
 202     my $val = "${pkg}::valid";
 203         my @out = keys %$val;
 204         push @out, keys %valid;
 205         return @out;
 206 }
 207
 208 #
 209 # return a prompt for a field
 210 #
 211
 212 sub field_prompt
 213 {
 214         my ($self, $ele) = @_;
 215         my $pkg = ref $self;
 216     my $val = "${pkg}::valid";
 217         return $val->{$ele} || $valid{$ele};
 218 }
 219
 220 #
 221 # generic AUTOLOAD for accessors
 222 #
 223 sub AUTOLOAD
 224 {
 225         my $self = shift;
 226         my $name = $AUTOLOAD;
 227         return if $name =~ /::DESTROY$/;
 228         $name =~ s/.*:://o;
 229
 230         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 231
 232         # this clever line of code creates a subroutine which takes over from autoload
 233         # from OO Perl - Conway
 234 #       *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
 235     @_ ? $self->{$name} = shift : $self->{$name} ;
 236 }
 237
 238 1;