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(isdbg('routecache'));
 107
 108         my $ta = [ gettimeofday ];
 109         my @s;
 110         eval {
 111                 while (my ($k, $v) = each  %list) {
 112                     push @s, "$k:" . $json->encode($v) . "\n";
 113             }
 114         };
 115         if (!$@ && @s) {
 116                 my $fh = IO::File->new(">$cachefn") or dbg("Route::User: ERROR writing $cachefn $!"), return;
 117                 print $fh $_ for (sort @s);
 118                 $fh->close;
 119         } else {
 120                 dbg("Route::User::write_cache error '$@'");
 121                 return;
 122         }
 123         my $diff = _diffms($ta);
 124         dbg("Route::User::write_cache time to write: $diff mS");
 125 }
 126
 127 sub read_cache
 128 {
 129         my $json = DXJSON->new;
 130         $json->canonical(isdbg('routecache'));
 131
 132         my $ta = [ gettimeofday ];
 133         my $count;
 134
 135         my $fh = IO::File->new("$cachefn") or dbg("Route::User: ERROR reading $cachefn $!"), return;
 136         while (my $l = <$fh>) {
 137                 chomp $l;
 138                 my ($k, $v) = split /:/, $l, 2;
 139                 $list{$k} = bless $json->decode($v) or dbg("Route::User: Error json error $! decoding '$v'"), next;
 140                 ++$count;
 141         }
 142         $fh->close if $fh;
 143
 144         my $diff = _diffms($ta);
 145         dbg("Route::User::read_cache time to read $count records from $cachefn : $diff mS");
 146 }
 147
 148 #
 149 # generic AUTOLOAD for accessors
 150 #
 151
 152 sub AUTOLOAD
 153 {
 154         no strict;
 155         my ($pkg,$name) = $AUTOLOAD =~ /^(.*)::(\w+)$/;
 156         return if $name eq 'DESTROY';
 157
 158         confess "Non-existant field '$AUTOLOAD'" unless $valid{$name} || $Route::valid{$name};
 159
 160         # this clever line of code creates a subroutine which takes over from autoload
 161         # from OO Perl - Conway
 162         *$AUTOLOAD = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 163         goto &$AUTOLOAD;
 164 #       *{"${pkg}::$name"} = sub {$_[0]->{$name} = $_[1] if @_ > 1; return $_[0]->{$name}};
 165 #       goto &{"${pkg}::$name"};
 166 }
 167
 168 1;