file.pm

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

  return unless defined $rec;
  if (substr($rec, -$self->{recseplen}) ne $self->{recsep}) {
    # improperly terminated final record --- quietly fix it.
#    my $ac = substr($rec, -$self->{recseplen});
#    $ac =~ s/\n/\\n/g;
    $self->{sawlastrec} = 1;
    unless ($self->{rdonly}) {
      local $\ = "";
      my $fh = $self->{fh};
      print $fh $self->{recsep};
    }
    $rec .= $self->{recsep};
  }
#  $self->{_read} += length($rec) if defined $rec;
  $rec;
}

sub _rw_stats {
  my $self = shift;
  @{$self}{'_read', '_written'};
}

################################################################
#
# Read cache management

sub _cache_flush {
  my ($self) = @_;
  $self->{cache}->reduce_size_to($self->{memory} - $self->{deferred_s});
}

sub _cache_too_full {
  my $self = shift;
  $self->{cache}->bytes + $self->{deferred_s} >= $self->{memory};
}

################################################################
#
# File custodial services
#


# We have read to the end of the file and have the offsets table
# entirely populated.  Now we need to write a new record beyond
# the end of the file.  We prepare for this by writing
# empty records into the file up to the position we want
#
# assumes that the offsets table already contains the offset of record $n,
# if it exists, and extends to the end of the file if not.
sub _extend_file_to {
  my ($self, $n) = @_;
  $self->_seek(-1);             # position after the end of the last record
  my $pos = $self->{offsets}[-1];

  # the offsets table has one entry more than the total number of records
  my $extras = $n - $#{$self->{offsets}};

  # Todo : just use $self->{recsep} x $extras here?
  while ($extras-- > 0) {
    $self->_write_record($self->{recsep});
    push @{$self->{offsets}}, int(tell $self->{fh});
  }
}

# Truncate the file at the current position
sub _chop_file {
  my $self = shift;
  truncate $self->{fh}, tell($self->{fh});
}


# compute the size of a buffer suitable for moving
# all the data in a file forward $n bytes
# ($n may be negative)
# The result should be at least $n.
sub _bufsize {
  my $n = shift;
  return 8192 if $n <= 0;
  my $b = $n & ~8191;
  $b += 8192 if $n & 8191;
  $b;
}

################################################################
#
# Miscellaneous public methods
#

# Lock the file
sub flock {
  my ($self, $op) = @_;
  unless (@_ <= 3) {
    my $pack = ref $self;
    croak "Usage: $pack\->flock([OPERATION])";
  }
  my $fh = $self->{fh};
  $op = LOCK_EX unless defined $op;
  my $locked = flock $fh, $op;
  
  if ($locked && ($op & (LOCK_EX | LOCK_SH))) {
    # If you're locking the file, then presumably it's because
    # there might have been a write access by another process.
    # In that case, the read cache contents and the offsets table
    # might be invalid, so discard them.  20030508
    $self->{offsets} = [0];
    $self->{cache}->empty;
  }

  $locked;
}

# Get/set autochomp option
sub autochomp {
  my $self = shift;
  if (@_) {
    my $old = $self->{autochomp};
    $self->{autochomp} = shift;
    $old;
  } else {
    $self->{autochomp};
  }
}

# Get offset table entries; returns offset of nth record
sub offset {
  my ($self, $n) = @_;

  if ($#{$self->{offsets}} < $n) {
    return if $self->{eof};     # request for record beyond the end of file
    my $o = $self->_fill_offsets_to($n);
    # If it's still undefined, there is no such record, so return 'undef'
    return unless defined $o;
   }
 
  $self->{offsets}[$n];
}

sub discard_offsets {
  my $self = shift;
  $self->{offsets} = [0];
}

################################################################
#
# Matters related to deferred writing
#

# Defer writes
sub defer {
  my $self = shift;
  $self->_stop_autodeferring;
  @{$self->{ad_history}} = ();
  $self->{defer} = 1;
}

# Flush deferred writes
#
# This could be better optimized to write the file in one pass, instead
# of one pass per block of records.  But that will require modifications
# to _twrite, so I should have a good _twrite test suite first.
sub flush {
  my $self = shift;

  $self->_flush;
  $self->{defer} = 0;
}

sub _old_flush {
  my $self = shift;
  my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});

  while (@writable) {
    # gather all consecutive records from the front of @writable
    my $first_rec = shift @writable;
    my $last_rec = $first_rec+1;
    ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
    --$last_rec;
    $self->_fill_offsets_to($last_rec);
    $self->_extend_file_to($last_rec);
    $self->_splice($first_rec, $last_rec-$first_rec+1, 
                   @{$self->{deferred}}{$first_rec .. $last_rec});
  }

  $self->_discard;               # clear out defered-write-cache
}

sub _flush {
  my $self = shift;
  my @writable = sort {$a<=>$b} (keys %{$self->{deferred}});
  my @args;
  my @adjust;

  while (@writable) {
    # gather all consecutive records from the front of @writable
    my $first_rec = shift @writable;
    my $last_rec = $first_rec+1;
    ++$last_rec, shift @writable while @writable && $last_rec == $writable[0];
    --$last_rec;
    my $end = $self->_fill_offsets_to($last_rec+1);
    if (not defined $end) {
      $self->_extend_file_to($last_rec);
      $end = $self->{offsets}[$last_rec];
    }
    my ($start) = $self->{offsets}[$first_rec];
    push @args,
         join("", @{$self->{deferred}}{$first_rec .. $last_rec}), # data
         $start,                                                  # position
         $end-$start;                                             # length
    push @adjust, [$first_rec, # starting at this position...
                   $last_rec-$first_rec+1,  # this many records...
                   # are replaced with these...
                   @{$self->{deferred}}{$first_rec .. $last_rec},
                  ];
  }

  $self->_mtwrite(@args);  # write multiple record groups
  $self->_discard;               # clear out defered-write-cache
  $self->_oadjust(@adjust);
}

# Discard deferred writes and disable future deferred writes
sub discard {
  my $self = shift;
  $self->_discard;
  $self->{defer} = 0;
}

# Discard deferred writes, but retain old deferred writing mode
sub _discard {
  my $self = shift;
  %{$self->{deferred}} = ();
  $self->{deferred_s}  = 0;
  $self->{deferred_max}  = -1;
  $self->{cache}->set_limit($self->{memory});
}

# Deferred writing is enabled, either explicitly ($self->{defer})
# or automatically ($self->{autodeferring})
sub _is_deferring {
  my $self = shift;
  $self->{defer} || $self->{autodeferring};
}

# The largest record number of any deferred record
sub _defer_max {
  my $self = shift;
  return $self->{deferred_max} if defined $self->{deferred_max};
  my $max = -1;
  for my $key (keys %{$self->{deferred}}) {
    $max = $key if $key > $max;
  }
  $self->{deferred_max} = $max;
  $max;
}

################################################################
#
# Matters related to autodeferment
#

# Get/set autodefer option
sub autodefer {
  my $self = shift;
  if (@_) {
    my $old = $self->{autodefer};
    $self->{autodefer} = shift;
    if ($old) {
      $self->_stop_autodeferring;
      @{$self->{ad_history}} = ();
    }
    $old;
  } else {
    $self->{autodefer};
  }
}

# The user is trying to store record #$n Record that in the history,
# and then enable (or disable) autodeferment if that seems useful.
# Note that it's OK for $n to be a non-number, as long as the function
# is prepared to deal with that.  Nobody else looks at the ad_history.
#
# Now, what does the ad_history mean, and what is this function doing?
# Essentially, the idea is to enable autodeferring when we see that the
# user has made three consecutive STORE calls to three consecutive records.
# ("Three" is actually ->{autodefer_threshhold}.)
# A STORE call for record #$n inserts $n into the autodefer history,
# and if the history contains three consecutive records, we enable 
# autodeferment.  An ad_history of [X, Y] means that the most recent
# STOREs were for records X, X+1, ..., Y, in that order.  
#
# Inserting a nonconsecutive number erases the history and starts over.
#
# Performing a special operation like SPLICE erases the history.
#
# There's one special case: CLEAR means that CLEAR was just called.
# In this case, we prime the history with [-2, -1] so that if the next
# write is for record 0, autodeferring goes on immediately.  This is for
# the common special case of "@a = (...)".
#
sub _annotate_ad_history {
  my ($self, $n) = @_;
  return unless $self->{autodefer}; # feature is disabled
  return if $self->{defer};     # already in explicit defer mode
  return unless $self->{offsets}[-1] >= $self->{autodefer_filelen_threshhold};

  local *H = $self->{ad_history};
  if ($n eq 'CLEAR') {
    @H = (-2, -1);              # prime the history with fake records
    $self->_stop_autodeferring;
  } elsif ($n =~ /^\d+$/) {
    if (@H == 0) {
      @H =  ($n, $n);
    } else {                    # @H == 2
      if ($H[1] == $n-1) {      # another consecutive record
        $H[1]++;
        if ($H[1] - $H[0] + 1 >= $self->{autodefer_threshhold}) {
          $self->{autodeferring} = 1;
        }
      } else {                  # nonconsecutive- erase and start over
        @H = ($n, $n);
        $self->_stop_autodeferring;
      }
    }
  } else {                      # SPLICE or STORESIZE or some such
    @H = ();
    $self->_stop_autodeferring;
  }
}

# If autodeferring was enabled, cut it out and discard the history
sub _stop_autodeferring {
  my $self = shift;
  if ($self->{autodeferring}) {
    $self->_flush;
  }
  $self->{autodeferring} = 0;
}

################################################################


# This is NOT a method.  It is here for two reasons:
#  1. To factor a fairly complicated block out of the constructor
#  2. To provide access for the test suite, which need to be sure
#     files are being written properly.
sub _default_recsep {
  my $recsep = $/;
  if ($^O eq 'MSWin32') {       # Dos too?
    # Windows users expect files to be terminated with \r\n
    # But $/ is set to \n instead
    # Note that this also transforms \n\n into \r\n\r\n.
    # That is a feature.
    $recsep =~ s/\n/\r\n/g;
  }
  $recsep;
}

# Utility function for _check_integrity
sub _ci_warn {
  my $msg = shift;
  $msg =~ s/\n/\\n/g;
  $msg =~ s/\r/\\r/g;
  print "# $msg\n";
}

# Given a file, make sure the cache is consistent with the
# file contents and the internal data structures are consistent with
# each other.  Returns true if everything checks out, false if not
#
# The $file argument is no longer used.  It is retained for compatibility
# with the existing test suite.
sub _check_integrity {
  my ($self, $file, $warn) = @_;
  my $rsl = $self->{recseplen};
  my $rs  = $self->{recsep};
  my $good = 1; 
  local *_;                     # local $_ does not work here
  local $DIAGNOSTIC = 1;

  if (not defined $rs) {
    _ci_warn("recsep is undef!");
    $good = 0;
  } elsif ($rs eq "") {
    _ci_warn("recsep is empty!");
    $good = 0;
  } elsif ($rsl != length $rs) {
    my $ln = length $rs;
    _ci_warn("recsep <$rs> has length $ln, should be $rsl");
    $good = 0;
  }

  if (not defined $self->{offsets}[0]) {
    _ci_warn("offset 0 is missing!");
    $good = 0;

  } elsif ($self->{offsets}[0] != 0) {
    _ci_warn("rec 0: offset <$self->{offsets}[0]> s/b 0!");
    $good = 0;
  }

  my $cached = 0;
  {
    local *F = $self->{fh};
    seek F, 0, SEEK_SET;
    local $. = 0;
    local $/ = $rs;

    while (<F>) {
      my $n = $. - 1;
      my $cached = $self->{cache}->_produce($n);
      my $offset = $self->{offsets}[$.];
      my $ao = tell F;
      if (defined $offset && $offset != $ao) {
        _ci_warn("rec $n: offset <$offset> actual <$ao>");
        $good = 0;
      }
      if (defined $cached && $_ ne $cached && ! $self->{deferred}{$n}) {
        $good = 0;
        _ci_warn("rec $n: cached <$cached> actual <$_>");
      }
      if (defined $cached && substr($cached, -$rsl) ne $rs) {
        $good = 0;
        _ci_warn("rec $n in the cache is missing the record separator");
      }
      if (! defined $offset && $self->{eof}) {
        $good = 0;
        _ci_warn("The offset table was marked complete, but it is missing element $.");
      }
    }
    if (@{$self->{offsets}} > $.+1) {
        $good = 0;
        my $n = @{$self->{offsets}};
        _ci_warn("The offset table has $n items, but the file has only $.");
    }

    my $deferring = $self->_is_deferring;
    for my $n ($self->{cache}->ckeys) {
      my $r = $self->{cache}->_produce($n);
      $cached += length($r);
      next if $n+1 <= $.;         # checked this already
      _ci_warn("spurious caching of record $n");
      $good = 0;
    }
    my $b = $self->{cache}->bytes;
    if ($cached != $b) {
      _ci_warn("cache size is $b, should be $cached");
      $good = 0;
    }
  }

  # That cache has its own set of tests
  $good = 0 unless $self->{cache}->_check_integrity;

  # Now let's check the deferbuffer
  # Unless deferred writing is enabled, it should be empty
  if (! $self->_is_deferring && %{$self->{deferred}}) {
    _ci_warn("deferred writing disabled, but deferbuffer nonempty");
    $good = 0;
  }