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