file.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

  # Any record in the deferbuffer should *not* be present in the readcache
  my $deferred_s = 0;
  while (my ($n, $r) = each %{$self->{deferred}}) {
    $deferred_s += length($r);
    if (defined $self->{cache}->_produce($n)) {
      _ci_warn("record $n is in the deferbuffer *and* the readcache");
      $good = 0;
    }
    if (substr($r, -$rsl) ne $rs) {
      _ci_warn("rec $n in the deferbuffer is missing the record separator");
      $good = 0;
    }
  }

  # Total size of deferbuffer should match internal total
  if ($deferred_s != $self->{deferred_s}) {
    _ci_warn("buffer size is $self->{deferred_s}, should be $deferred_s");
    $good = 0;
  }

  # Total size of deferbuffer should not exceed the specified limit
  if ($deferred_s > $self->{dw_size}) {
    _ci_warn("buffer size is $self->{deferred_s} which exceeds the limit of $self->{dw_size}");
    $good = 0;
  }

  # Total size of cached data should not exceed the specified limit
  if ($deferred_s + $cached > $self->{memory}) {
    my $total = $deferred_s + $cached;
    _ci_warn("total stored data size is $total which exceeds the limit of $self->{memory}");
    $good = 0;
  }

  # Stuff related to autodeferment
  if (!$self->{autodefer} && @{$self->{ad_history}}) {
    _ci_warn("autodefer is disabled, but ad_history is nonempty");
    $good = 0;
  }
  if ($self->{autodeferring} && $self->{defer}) {
    _ci_warn("both autodeferring and explicit deferring are active");
    $good = 0;
  }
  if (@{$self->{ad_history}} == 0) {
    # That's OK, no additional tests required
  } elsif (@{$self->{ad_history}} == 2) {
    my @non_number = grep !/^-?\d+$/, @{$self->{ad_history}};
    if (@non_number) {
      my $msg;
      { local $" = ')(';
        $msg = "ad_history contains non-numbers (@{$self->{ad_history}})";
      }
      _ci_warn($msg);
      $good = 0;
    } elsif ($self->{ad_history}[1] < $self->{ad_history}[0]) {
      _ci_warn("ad_history has nonsensical values @{$self->{ad_history}}");
      $good = 0;
    }
  } else {
    _ci_warn("ad_history has bad length <@{$self->{ad_history}}>");
    $good = 0;
  }

  $good;
}

################################################################
#
# Tie::File::Cache
#
# Read cache

package Tie::File::Cache;
$Tie::File::Cache::VERSION = $Tie::File::VERSION;
use Carp ':DEFAULT', 'confess';

sub HEAP () { 0 }
sub HASH () { 1 }
sub MAX  () { 2 }
sub BYTES() { 3 }
#sub STAT () { 4 } # Array with request statistics for each record
#sub MISS () { 5 } # Total number of cache misses
#sub REQ  () { 6 } # Total number of cache requests 
use strict 'vars';

sub new {
  my ($pack, $max) = @_;
  local *_;
  croak "missing argument to ->new" unless defined $max;
  my $self = [];
  bless $self => $pack;
  @$self = (Tie::File::Heap->new($self), {}, $max, 0);
  $self;
}

sub adj_limit {
  my ($self, $n) = @_;
  $self->[MAX] += $n;
}

sub set_limit {
  my ($self, $n) = @_;
  $self->[MAX] = $n;
}

# For internal use only
# Will be called by the heap structure to notify us that a certain 
# piece of data has moved from one heap element to another.
# $k is the hash key of the item
# $n is the new index into the heap at which it is stored
# If $n is undefined, the item has been removed from the heap.
sub _heap_move {
  my ($self, $k, $n) = @_;
  if (defined $n) {
    $self->[HASH]{$k} = $n;
  } else {
    delete $self->[HASH]{$k};
  }
}

sub insert {
  my ($self, $key, $val) = @_;
  local *_;
  croak "missing argument to ->insert" unless defined $key;
  unless (defined $self->[MAX]) {
    confess "undefined max" ;
  }
  confess "undefined val" unless defined $val;
  return if length($val) > $self->[MAX];

#  if ($self->[STAT]) {
#    $self->[STAT][$key] = 1;
#    return;
#  }

  my $oldnode = $self->[HASH]{$key};
  if (defined $oldnode) {
    my $oldval = $self->[HEAP]->set_val($oldnode, $val);
    $self->[BYTES] -= length($oldval);
  } else {
    $self->[HEAP]->insert($key, $val);
  }
  $self->[BYTES] += length($val);
  $self->flush if $self->[BYTES] > $self->[MAX];
}

sub expire {
  my $self = shift;
  my $old_data = $self->[HEAP]->popheap;
  return unless defined $old_data;
  $self->[BYTES] -= length $old_data;
  $old_data;
}

sub remove {
  my ($self, @keys) = @_;
  my @result;

#  if ($self->[STAT]) {
#    for my $key (@keys) {
#      $self->[STAT][$key] = 0;
#    }
#    return;
#  }

  for my $key (@keys) {
    next unless exists $self->[HASH]{$key};
    my $old_data = $self->[HEAP]->remove($self->[HASH]{$key});
    $self->[BYTES] -= length $old_data;
    push @result, $old_data;
  }
  @result;
}

sub lookup {
  my ($self, $key) = @_;
  local *_;
  croak "missing argument to ->lookup" unless defined $key;

#  if ($self->[STAT]) {
#    $self->[MISS]++  if $self->[STAT][$key]++ == 0;
#    $self->[REQ]++;
#    my $hit_rate = 1 - $self->[MISS] / $self->[REQ];
#    # Do some testing to determine this threshhold
#    $#$self = STAT - 1 if $hit_rate > 0.20; 
#  }

  if (exists $self->[HASH]{$key}) {
    $self->[HEAP]->lookup($self->[HASH]{$key});
  } else {
    return;
  }
}

# For internal use only
sub _produce {
  my ($self, $key) = @_;
  my $loc = $self->[HASH]{$key};
  return unless defined $loc;
  $self->[HEAP][$loc][2];
}

# For internal use only
sub _promote {
  my ($self, $key) = @_;
  $self->[HEAP]->promote($self->[HASH]{$key});
}

sub empty {
  my ($self) = @_;
  %{$self->[HASH]} = ();
    $self->[BYTES] = 0;
    $self->[HEAP]->empty;
#  @{$self->[STAT]} = ();
#    $self->[MISS] = 0;
#    $self->[REQ] = 0;
}

sub is_empty {
  my ($self) = @_;
  keys %{$self->[HASH]} == 0;
}

sub update {
  my ($self, $key, $val) = @_;
  local *_;
  croak "missing argument to ->update" unless defined $key;
  if (length($val) > $self->[MAX]) {
    my ($oldval) = $self->remove($key);
    $self->[BYTES] -= length($oldval) if defined $oldval;
  } elsif (exists $self->[HASH]{$key}) {
    my $oldval = $self->[HEAP]->set_val($self->[HASH]{$key}, $val);
    $self->[BYTES] += length($val);
    $self->[BYTES] -= length($oldval) if defined $oldval;
  } else {
    $self->[HEAP]->insert($key, $val);
    $self->[BYTES] += length($val);
  }
  $self->flush;
}

sub rekey {
  my ($self, $okeys, $nkeys) = @_;
  local *_;
  my %map;
  @map{@$okeys} = @$nkeys;
  croak "missing argument to ->rekey" unless defined $nkeys;
  croak "length mismatch in ->rekey arguments" unless @$nkeys == @$okeys;
  my %adjusted;                 # map new keys to heap indices
  # You should be able to cut this to one loop TODO XXX
  for (0 .. $#$okeys) {
    $adjusted{$nkeys->[$_]} = delete $self->[HASH]{$okeys->[$_]};
  }
  while (my ($nk, $ix) = each %adjusted) {
    # @{$self->[HASH]}{keys %adjusted} = values %adjusted;
    $self->[HEAP]->rekey($ix, $nk);
    $self->[HASH]{$nk} = $ix;
  }
}

sub ckeys {
  my $self = shift;
  my @a = keys %{$self->[HASH]};
  @a;
}

# Return total amount of cached data
sub bytes {
  my $self = shift;
  $self->[BYTES];
}

# Expire oldest item from cache until cache size is smaller than $max
sub reduce_size_to {
  my ($self, $max) = @_;
  until ($self->[BYTES] <= $max) {
    # Note that Tie::File::Cache::expire has been inlined here
    my $old_data = $self->[HEAP]->popheap;
    return unless defined $old_data;
    $self->[BYTES] -= length $old_data;
  }
}

# Why not just $self->reduce_size_to($self->[MAX])?
# Try this when things stabilize   TODO XXX
# If the cache is too full, expire the oldest records
sub flush {
  my $self = shift;
  $self->reduce_size_to($self->[MAX]) if $self->[BYTES] > $self->[MAX];
}

# For internal use only
sub _produce_lru {
  my $self = shift;
  $self->[HEAP]->expire_order;
}

BEGIN { *_ci_warn = \&Tie::File::_ci_warn }

sub _check_integrity {          # For CACHE
  my $self = shift;
  my $good = 1;

  # Test HEAP
  $self->[HEAP]->_check_integrity or $good = 0;

  # Test HASH
  my $bytes = 0;
  for my $k (keys %{$self->[HASH]}) {
    if ($k ne '0' && $k !~ /^[1-9][0-9]*$/) {
      $good = 0;
      _ci_warn "Cache hash key <$k> is non-numeric";
    }

    my $h = $self->[HASH]{$k};
    if (! defined $h) {
      $good = 0;
      _ci_warn "Heap index number for key $k is undefined";
    } elsif ($h == 0) {
      $good = 0;
      _ci_warn "Heap index number for key $k is zero";
    } else {
      my $j = $self->[HEAP][$h];
      if (! defined $j) {
        $good = 0;
        _ci_warn "Heap contents key $k (=> $h) are undefined";
      } else {
        $bytes += length($j->[2]);
        if ($k ne $j->[1]) {
          $good = 0;
          _ci_warn "Heap contents key $k (=> $h) is $j->[1], should be $k";
        }
      }
    }
  }

  # Test BYTES
  if ($bytes != $self->[BYTES]) {
    $good = 0;
    _ci_warn "Total data in cache is $bytes, expected $self->[BYTES]";
  }

  # Test MAX
  if ($bytes > $self->[MAX]) {
    $good = 0;
    _ci_warn "Total data in cache is $bytes, exceeds maximum $self->[MAX]";
  }

  return $good;
}

sub delink {
  my $self = shift;
  $self->[HEAP] = undef;        # Bye bye heap
}

################################################################
#
# Tie::File::Heap
#
# Heap data structure for use by cache LRU routines

package Tie::File::Heap;
use Carp ':DEFAULT', 'confess';
$Tie::File::Heap::VERSION = $Tie::File::Cache::VERSION;
sub SEQ () { 0 };
sub KEY () { 1 };
sub DAT () { 2 };

sub new {
  my ($pack, $cache) = @_;
  die "$pack: Parent cache object $cache does not support _heap_move method"
    unless eval { $cache->can('_heap_move') };
  my $self = [[0,$cache,0]];
  bless $self => $pack;
}

# Allocate a new sequence number, larger than all previously allocated numbers
sub _nseq {
  my $self = shift;
  $self->[0][0]++;
}

sub _cache {
  my $self = shift;
  $self->[0][1];
}

sub _nelts {
  my $self = shift;
  $self->[0][2];
}

sub _nelts_inc {
  my $self = shift;
  ++$self->[0][2];
}  

sub _nelts_dec {
  my $self = shift;
  --$self->[0][2];
}  

sub is_empty {
  my $self = shift;
  $self->_nelts == 0;
}

sub empty {
  my $self = shift;
  $#$self = 0;
  $self->[0][2] = 0;
  $self->[0][0] = 0;            # might as well reset the sequence numbers
}

# notify the parent cache object that we moved something
sub _heap_move {
  my $self = shift;
  $self->_cache->_heap_move(@_);
}

# Insert a piece of data into the heap with the indicated sequence number.
# The item with the smallest sequence number is always at the top.
# If no sequence number is specified, allocate a new one and insert the
# item at the bottom.
sub insert {
  my ($self, $key, $data, $seq) = @_;
  $seq = $self->_nseq unless defined $seq;
  $self->_insert_new([$seq, $key, $data]);
}

# Insert a new, fresh item at the bottom of the heap
sub _insert_new {
  my ($self, $item) = @_;
  my $i = @$self;
  $i = int($i/2) until defined $self->[$i/2];
  $self->[$i] = $item;
  $self->[0][1]->_heap_move($self->[$i][KEY], $i);
  $self->_nelts_inc;
}

# Insert [$data, $seq] pair at or below item $i in the heap.
# If $i is omitted, default to 1 (the top element.)
sub _insert {
  my ($self, $item, $i) = @_;
#  $self->_check_loc($i) if defined $i;
  $i = 1 unless defined $i;
  until (! defined $self->[$i]) {
    if ($self->[$i][SEQ] > $item->[SEQ]) { # inserted item is older
      ($self->[$i], $item) = ($item, $self->[$i]);
      $self->[0][1]->_heap_move($self->[$i][KEY], $i);
    }
    # If either is undefined, go that way.  Otherwise, choose at random
    my $dir;
    $dir = 0 if !defined $self->[2*$i];
    $dir = 1 if !defined $self->[2*$i+1];
    $dir = int(rand(2)) unless defined $dir;
    $i = 2*$i + $dir;
  }