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 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  18 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ ) || 0;
  19 $main::build += $VERSION;
  20 $main::branch += $BRANCH;
  21
  22 use vars qw(%list %valid @ISA $max $filterdef);
  23 @ISA = qw(Route);
  24
  25 %valid = (
  26                   parent => '0,Parent Calls,parray',
  27 );
  28
  29 $filterdef = $Route::filterdef;
  30 %list = ();
  31 $max = 0;
  32
  33 sub count
  34 {
  35         my $n = scalar(keys %list);
  36         $max = $n if $n > $max;
  37         return $n;
  38 }
  39
  40 sub max
  41 {
  42         count();
  43         return $max;
  44 }
  45
  46 sub new
  47 {
  48         my $pkg = shift;
  49         my $call = uc shift;
  50         my $ncall = uc shift;
  51         my $flags = shift;
  52         confess "already have $call in $pkg" if $list{$call};
  53
  54         my $self = $pkg->SUPER::new($call);
  55         $self->{parent} = [ $ncall ];
  56         $self->{flags} = $flags;
  57         $list{$call} = $self;
  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         $self->delparent($pref);
  72         unless (@{$self->{parent}}) {
  73                 delete $list{$self->{call}};
  74                 return $self;
  75         }
  76         return undef;
  77 }
  78
  79 sub get
  80 {
  81         my $call = shift;
  82         $call = shift if ref $call;
  83         my $ref = $list{uc $call};
  84         dbg("Failed to get User $call" ) if !$ref && isdbg('routerr');
  85         return $ref;
  86 }
  87
  88 sub addparent
  89 {
  90         my $self = shift;
  91     return $self->_addlist('parent', @_);
  92 }
  93
  94 sub delparent
  95 {
  96         my $self = shift;
  97     return $self->_dellist('parent', @_);
  98 }
  99
 100 #
 101 # generic AUTOLOAD for accessors
 102 #
 103
 104 sub AUTOLOAD
 105 {
 106         no strict;
 107
 108         my $self = shift;
 109         $name = $AUTOLOAD;
 110         return if $name =~ /::DESTROY$/;
 111         $name =~ s/.*:://o;
 112
 113         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 114
 115         # this clever line of code creates a subroutine which takes over from autoload
 116         # from OO Perl - Conway
 117 #       *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
 118     @_ ? $self->{$name} = shift : $self->{$name} ;
 119 }
 120
 121 1;