perl/Route/User.pm

   1 #
   2 # User routing routines
   3 #
   4 # Copyright (c) 2001 Dirk Koopman G1TLH
   5 #
   6 #
   7 #
   8
   9 package Route::User;
  10
  11 use DXDebug;
  12 use Route;
  13 use DXUtil;
  14
  15 use strict;
  16
  17 use vars qw(%list %valid @ISA $max $filterdef);
  18 @ISA = qw(Route);
  19
  20 $filterdef = $Route::filterdef;
  21 %list = ();
  22 $max = 0;
  23
  24 sub count
  25 {
  26         my $n = scalar(keys %list);
  27         $max = $n if $n > $max;
  28         return $n;
  29 }
  30
  31 sub max
  32 {
  33         count();
  34         return $max;
  35 }
  36
  37 sub new
  38 {
  39         my $pkg = shift;
  40         my $call = uc shift;
  41         my $ncall = uc shift;
  42         my $flags = shift;
  43         my $ip = shift;
  44
  45         confess "already have $call in $pkg" if $list{$call};
  46
  47         my $self = $pkg->SUPER::new($call);
  48         $self->{parent} = [ $ncall ];
  49         $self->{flags} = $flags || Route::here(1);
  50         $self->{ip} = $ip if defined $ip;
  51         $list{$call} = $self;
  52         dbg("CLUSTER: user $call added") if isdbg('cluster');
  53
  54         return $self;
  55 }
  56
  57 sub get_all
  58 {
  59         return values %list;
  60 }
  61
  62 sub del
  63 {
  64         my $self = shift;
  65         my $pref = shift;
  66         my $call = $self->{call};
  67         $self->delparent($pref);
  68         unless (@{$self->{parent}}) {
  69                 delete $list{$call};
  70                 dbg("CLUSTER: user $call deleted") if isdbg('cluster');
  71                 return $self;
  72         }
  73         return undef;
  74 }
  75
  76 sub get
  77 {
  78         my $call = shift;
  79         $call = shift if ref $call;
  80         my $ref = $list{uc $call};
  81         dbg("Failed to get User $call" ) if !$ref && isdbg('routerr');
  82         return $ref;
  83 }
  84
  85 sub addparent
  86 {
  87         my $self = shift;
  88     return $self->_addlist('parent', @_);
  89 }
  90
  91 sub delparent
  92 {
  93         my $self = shift;
  94     return $self->_dellist('parent', @_);
  95 }
  96
  97 #
  98 # generic AUTOLOAD for accessors
  99 #
 100
 101 sub AUTOLOAD
 102 {
 103         no strict;
 104         my ($pkg,$name) = $AUTOLOAD =~ /^(.*)::(\w+)$/;
 105         return if $name eq 'DESTROY';
 106
 107         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 108
 109         # this clever line of code creates a subroutine which takes over from autoload
 110         # from OO Perl - Conway
 111         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 112         goto &$AUTOLOAD;
 113 #       *{"${pkg}::$name"} = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 114 #       goto &{"${pkg}::$name"};
 115 }
 116
 117 1;