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 use DXJSON;
  15 use Time::HiRes qw(gettimeofday);
  16
  17 use strict;
  18
  19 use vars qw(%list %valid @ISA $max $filterdef);
  20 @ISA = qw(Route);
  21
  22 $filterdef = $Route::filterdef;
  23 %list = ();
  24 $max = 0;
  25
  26 our $cachefn = localdata('route_user_cache');
  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         my $ip = shift;
  48
  49         confess "already have $call in $pkg" if $list{$call};
  50
  51         my $self = $pkg->SUPER::new($call);
  52         $self->{parent} = [ $ncall ];
  53         $self->{flags} = $flags || Route::here(1);
  54         $self->{ip} = $ip if defined $ip;
  55         $list{$call} = $self;
  56         dbg("CLUSTER: user $call added") if isdbg('cluster');
  57
  58         return $self;
  59 }
  60
  61 sub get_all
  62 {
  63         return values %list;
  64 }
  65
  66 sub del
  67 {
  68         my $self = shift;
  69         my $pref = shift;
  70         my $call = $self->{call};
  71         $self->delparent($pref);
  72         unless (@{$self->{parent}}) {
  73                 delete $list{$call};
  74                 dbg("CLUSTER: user $call deleted") if isdbg('cluster');
  75                 return $self;
  76         }
  77         return undef;
  78 }
  79
  80 sub get
  81 {
  82         my $call = shift;
  83         $call = shift if ref $call;
  84         my $ref = $list{uc $call};
  85         dbg("Failed to get User $call" ) if !$ref && isdbg('routerr');
  86         return $ref;
  87 }
  88
  89 sub addparent
  90 {
  91         my $self = shift;
  92     return $self->_addlist('parent', @_);
  93 }
  94
  95 sub delparent
  96 {
  97         my $self = shift;
  98     return $self->_dellist('parent', @_);
  99 }
 100
 101 sub TO_JSON { return { %{ shift() } }; }
 102
 103 sub write_cache
 104 {
 105         my $json = DXJSON->new;
 106         $json->canonical(0)->allow_blessed(1)->convert_blessed(1);
 107
 108         my $ta = [ gettimeofday ];
 109         $json->indent(1)->canonical(1) if isdbg('routecache');
 110         my $s = eval {$json->encode(\%list)};
 111         if ($s) {
 112                 my $fh = IO::File->new(">$cachefn") or confess("writing $cachefn $!");
 113                 $fh->print($s);
 114                 $fh->close;
 115         } else {
 116                 dbg("Route::User:Write_cache error '$@'");
 117                 return;
 118         }
 119         $json->indent(0)->canonical(0);
 120         my $diff = _diffms($ta);
 121         my $size = sprintf('%.3fKB', (length($s) / 1000));
 122         dbg("Route::User:WRITE_CACHE size: $size time to write: $diff mS");
 123 }
 124
 125 #
 126 # generic AUTOLOAD for accessors
 127 #
 128
 129 sub AUTOLOAD
 130 {
 131         no strict;
 132         my ($pkg,$name) = $AUTOLOAD =~ /^(.*)::(\w+)$/;
 133         return if $name eq 'DESTROY';
 134
 135         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 136
 137         # this clever line of code creates a subroutine which takes over from autoload
 138         # from OO Perl - Conway
 139         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 140         goto &$AUTOLOAD;
 141 #       *{"${pkg}::$name"} = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 142 #       goto &{"${pkg}::$name"};
 143 }
 144
 145 1;