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(%list %valid @ISA $max);
  17 @ISA = qw(Route);
  18
  19 %valid = (
  20                   parent => '0,Parent Calls,parray',
  21 );
  22
  23 %list = ();
  24 $max = 0;
  25
  26 sub count
  27 {
  28         my $n = scalar %list;
  29         $max = $n if $n > $max;
  30         return $n;
  31 }
  32
  33 sub max
  34 {
  35         return $max;
  36 }
  37
  38 sub new
  39 {
  40         my $pkg = shift;
  41         my $call = uc shift;
  42         my $ncall = uc shift;
  43         my $flags = shift;
  44         confess "already have $call in $pkg" if $list{$call};
  45
  46         my $self = $pkg->SUPER::new($call);
  47         $self->{parent} = [ $ncall ];
  48         $self->{flags} = $flags;
  49         $list{$call} = $self;
  50
  51         return $self;
  52 }
  53
  54 sub del
  55 {
  56         my $self = shift;
  57         my $pref = shift;
  58         my $ref = $self->delparent($pref->{call});
  59         return () if @$ref;
  60         delete $list{$self->{call}};
  61         return ($ref);
  62 }
  63
  64 sub get
  65 {
  66         my $call = shift;
  67         $call = shift if ref $call;
  68         return $list{uc $call};
  69 }
  70
  71 sub addparent
  72 {
  73         my $self = shift;
  74     return $self->_addlist('parent', @_);
  75 }
  76
  77 sub delparent
  78 {
  79         my $self = shift;
  80     return $self->_dellist('parent', @_);
  81 }
  82
  83 #
  84 # generic AUTOLOAD for accessors
  85 #
  86
  87 sub AUTOLOAD
  88 {
  89         no strict;
  90
  91         my $self = shift;
  92         $name = $AUTOLOAD;
  93         return if $name =~ /::DESTROY$/;
  94         $name =~ s/.*:://o;
  95
  96         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
  97
  98         # this clever line of code creates a subroutine which takes over from autoload
  99         # from OO Perl - Conway
 100 #       *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
 101     @_ ? $self->{$name} = shift : $self->{$name} ;
 102 }
 103
 104 1;