perl/Route/User.pm

   1 #
   2 # User routing routines
   3 #
   4 # Copyright (c) 2001 Dirk Koopman G1TLH
   5 #
   6 # $Id$
   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 );
  23
  24 $filterdef = $Route::filterdef;
  25 %list = ();
  26 $max = 0;
  27
  28 sub count
  29 {
  30         my $n = scalar(keys %list);
  31         $max = $n if $n > $max;
  32         return $n;
  33 }
  34
  35 sub max
  36 {
  37         count();
  38         return $max;
  39 }
  40
  41 sub new
  42 {
  43         my $pkg = shift;
  44         my $call = uc shift;
  45         my $ncall = uc shift;
  46         my $flags = shift;
  47         confess "already have $call in $pkg" if $list{$call};
  48
  49         my $self = $pkg->SUPER::new($call);
  50         $self->{parent} = [ $ncall ];
  51         $self->{flags} = $flags || Route::here(1);
  52         $list{$call} = $self;
  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         $self->delparent($pref);
  67         unless (@{$self->{parent}}) {
  68                 delete $list{$self->{call}};
  69                 return $self;
  70         }
  71         return undef;
  72 }
  73
  74 sub get
  75 {
  76         my $call = shift;
  77         $call = shift if ref $call;
  78         my $ref = $list{uc $call};
  79         dbg("Failed to get User $call" ) if !$ref && isdbg('routerr');
  80         return $ref;
  81 }
  82
  83 sub addparent
  84 {
  85         my $self = shift;
  86     return $self->_addlist('parent', @_);
  87 }
  88
  89 sub delparent
  90 {
  91         my $self = shift;
  92     return $self->_dellist('parent', @_);
  93 }
  94
  95 #
  96 # generic AUTOLOAD for accessors
  97 #
  98
  99 sub AUTOLOAD
 100 {
 101         no strict;
 102         my ($pkg,$name) = $AUTOLOAD =~ /^(.*)::(\w+)$/;
 103         return if $name eq 'DESTROY';
 104
 105         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 106
 107         # this clever line of code creates a subroutine which takes over from autoload
 108         # from OO Perl - Conway
 109         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 110         goto &$AUTOLOAD;
 111 #       *{"${pkg}::$name"} = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 112 #       goto &{"${pkg}::$name"};
 113 }
 114
 115 1;