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
  14 use strict;
  15
  16 use vars qw($VERSION $BRANCH);
  17
  18 main::mkver($VERSION = q$Revision$);
  19
  20 use vars qw(%list %valid @ISA $max $filterdef);
  21 @ISA = qw(Route);
  22
  23 %valid = (
  24                   parent => '0,Parent Calls,parray',
  25 );
  26
  27 $filterdef = $Route::filterdef;
  28 %list = ();
  29 $max = 0;
  30
  31 sub count
  32 {
  33         my $n = scalar(keys %list);
  34         $max = $n if $n > $max;
  35         return $n;
  36 }
  37
  38 sub max
  39 {
  40         count();
  41         return $max;
  42 }
  43
  44 sub new
  45 {
  46         my $pkg = shift;
  47         my $call = uc shift;
  48         my $ncall = uc shift;
  49         my $flags = shift;
  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} = 0 || $flags;
  55         $list{$call} = $self;
  56
  57         return $self;
  58 }
  59
  60 sub get_all
  61 {
  62         return values %list;
  63 }
  64
  65 sub del
  66 {
  67         my $self = shift;
  68         my $pref = shift;
  69         $self->delparent($pref);
  70         unless (@{$self->{parent}}) {
  71                 delete $list{$self->{call}};
  72                 return $self;
  73         }
  74         return undef;
  75 }
  76
  77 sub get
  78 {
  79         my $call = shift;
  80         $call = shift if ref $call;
  81         my $ref = $list{uc $call};
  82         dbg("Failed to get User $call" ) if !$ref && isdbg('routerr');
  83         return $ref;
  84 }
  85
  86 sub addparent
  87 {
  88         my $self = shift;
  89     return $self->_addlist('parent', shift);
  90 }
  91
  92 sub delparent
  93 {
  94         my $self = shift;
  95     return $self->_dellist('parent', shift);
  96 }
  97
  98 sub has_parent
  99 {
 100         my $self = shift;
 101         return $self->_haslist('parent', shift);
 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;