file.pm

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

package Tie::File;
require 5.005;
use Carp ':DEFAULT', 'confess';
use POSIX 'SEEK_SET';
use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX', 'LOCK_SH', 'O_WRONLY', 'O_RDONLY';
sub O_ACCMODE () { O_RDONLY | O_RDWR | O_WRONLY }


$VERSION = "0.97_02";
my $DEFAULT_MEMORY_SIZE = 1<<21;    # 2 megabytes
my $DEFAULT_AUTODEFER_THRESHHOLD = 3; # 3 records
my $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD = 65536; # 16 disk blocksful

my %good_opt = map {$_ => 1, "-$_" => 1}
                 qw(memory dw_size mode recsep discipline 
                    autodefer autochomp autodefer_threshhold concurrent);

sub TIEARRAY {
  if (@_ % 2 != 0) {
    croak "usage: tie \@array, $_[0], filename, [option => value]...";
  }
  my ($pack, $file, %opts) = @_;

  # transform '-foo' keys into 'foo' keys
  for my $key (keys %opts) {
    unless ($good_opt{$key}) {
      croak("$pack: Unrecognized option '$key'\n");
    }
    my $okey = $key;
    if ($key =~ s/^-+//) {
      $opts{$key} = delete $opts{$okey};
    }
  }

  if ($opts{concurrent}) {
    croak("$pack: concurrent access not supported yet\n");
  }

  unless (defined $opts{memory}) {
    # default is the larger of the default cache size and the 
    # deferred-write buffer size (if specified)
    $opts{memory} = $DEFAULT_MEMORY_SIZE;
    $opts{memory} = $opts{dw_size}
      if defined $opts{dw_size} && $opts{dw_size} > $DEFAULT_MEMORY_SIZE;
    # Dora Winifred Read
  }
  $opts{dw_size} = $opts{memory} unless defined $opts{dw_size};
  if ($opts{dw_size} > $opts{memory}) {
      croak("$pack: dw_size may not be larger than total memory allocation\n");
  }
  # are we in deferred-write mode?
  $opts{defer} = 0 unless defined $opts{defer};
  $opts{deferred} = {};         # no records are presently deferred
  $opts{deferred_s} = 0;        # count of total bytes in ->{deferred}
  $opts{deferred_max} = -1;     # empty

  # What's a good way to arrange that this class can be overridden?
  $opts{cache} = Tie::File::Cache->new($opts{memory});

  # autodeferment is enabled by default
  $opts{autodefer} = 1 unless defined $opts{autodefer};
  $opts{autodeferring} = 0;     # but is not initially active
  $opts{ad_history} = [];
  $opts{autodefer_threshhold} = $DEFAULT_AUTODEFER_THRESHHOLD
    unless defined $opts{autodefer_threshhold};
  $opts{autodefer_filelen_threshhold} = $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD
    unless defined $opts{autodefer_filelen_threshhold};

  $opts{offsets} = [0];
  $opts{filename} = $file;
  unless (defined $opts{recsep}) { 
    $opts{recsep} = _default_recsep();
  }
  $opts{recseplen} = length($opts{recsep});
  if ($opts{recseplen} == 0) {
    croak "Empty record separator not supported by $pack";
  }

  $opts{autochomp} = 1 unless defined $opts{autochomp};

  $opts{mode} = O_CREAT|O_RDWR unless defined $opts{mode};
  $opts{rdonly} = (($opts{mode} & O_ACCMODE) == O_RDONLY);
  $opts{sawlastrec} = undef;

  my $fh;

  if (UNIVERSAL::isa($file, 'GLOB')) {
    # We use 1 here on the theory that some systems 
    # may not indicate failure if we use 0.
    # MSWin32 does not indicate failure with 0, but I don't know if
    # it will indicate failure with 1 or not.
    unless (seek $file, 1, SEEK_SET) {
      croak "$pack: your filehandle does not appear to be seekable";
    }
    seek $file, 0, SEEK_SET;    # put it back
    $fh = $file;                # setting binmode is the user's problem
  } elsif (ref $file) {
    croak "usage: tie \@array, $pack, filename, [option => value]...";
  } else {
    # $fh = \do { local *FH };  # XXX this is buggy
    if ($] < 5.006) {
	# perl 5.005 and earlier don't autovivify filehandles
	require Symbol;
	$fh = Symbol::gensym();
    }
    sysopen $fh, $file, $opts{mode}, 0666 or return;
    binmode $fh;
    ++$opts{ourfh};
  }
  { my $ofh = select $fh; $| = 1; select $ofh } # autoflush on write
  if (defined $opts{discipline} && $] >= 5.006) {
    # This avoids a compile-time warning under 5.005
    eval 'binmode($fh, $opts{discipline})';
    croak $@ if $@ =~ /unknown discipline/i;
    die if $@;
  }
  $opts{fh} = $fh;

  bless \%opts => $pack;
}

sub FETCH {
  my ($self, $n) = @_;
  my $rec;

  # check the defer buffer
  $rec = $self->{deferred}{$n} if exists $self->{deferred}{$n};
  $rec = $self->_fetch($n) unless defined $rec;

  # inlined _chomp1
  substr($rec, - $self->{recseplen}) = ""
    if defined $rec && $self->{autochomp};
  $rec;
}

# Chomp many records in-place; return nothing useful
sub _chomp {
  my $self = shift;
  return unless $self->{autochomp};
  if ($self->{autochomp}) {
    for (@_) {
      next unless defined;
      substr($_, - $self->{recseplen}) = "";
    }
  }
}

# Chomp one record in-place; return modified record
sub _chomp1 {
  my ($self, $rec) = @_;
  return $rec unless $self->{autochomp};
  return unless defined $rec;
  substr($rec, - $self->{recseplen}) = "";
  $rec;
}

sub _fetch {
  my ($self, $n) = @_;

  # check the record cache
  { my $cached = $self->{cache}->lookup($n);
    return $cached if defined $cached;
  }

  if ($#{$self->{offsets}} < $n) {
    return if $self->{eof};  # request for record beyond 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;
  }

  my $fh = $self->{FH};
  $self->_seek($n);             # we can do this now that offsets is populated
  my $rec = $self->_read_record;

# If we happen to have just read the first record, check to see if
# the length of the record matches what 'tell' says.  If not, Tie::File
# won't work, and should drop dead.
#
#  if ($n == 0 && defined($rec) && tell($self->{fh}) != length($rec)) {
#    if (defined $self->{discipline}) {
#      croak "I/O discipline $self->{discipline} not supported";
#    } else {
#      croak "File encoding not supported";
#    }
#  }

  $self->{cache}->insert($n, $rec) if defined $rec && not $self->{flushing};
  $rec;
}

sub STORE {
  my ($self, $n, $rec) = @_;
  die "STORE called from _check_integrity!" if $DIAGNOSTIC;

  $self->_fixrecs($rec);

  if ($self->{autodefer}) {
    $self->_annotate_ad_history($n);
  }

  return $self->_store_deferred($n, $rec) if $self->_is_deferring;


  # We need this to decide whether the new record will fit
  # It incidentally populates the offsets table 
  # Note we have to do this before we alter the cache
  # 20020324 Wait, but this DOES alter the cache.  TODO BUG?
  my $oldrec = $self->_fetch($n);

  if (not defined $oldrec) {
    # We're storing a record beyond the end of the file
    $self->_extend_file_to($n+1);
    $oldrec = $self->{recsep};
  }
#  return if $oldrec eq $rec;    # don't bother
  my $len_diff = length($rec) - length($oldrec);

  # length($oldrec) here is not consistent with text mode  TODO XXX BUG
  $self->_mtwrite($rec, $self->{offsets}[$n], length($oldrec));
  $self->_oadjust([$n, 1, $rec]);
  $self->{cache}->update($n, $rec);
}

sub _store_deferred {
  my ($self, $n, $rec) = @_;
  $self->{cache}->remove($n);
  my $old_deferred = $self->{deferred}{$n};

  if (defined $self->{deferred_max} && $n > $self->{deferred_max}) {
    $self->{deferred_max} = $n;
  }
  $self->{deferred}{$n} = $rec;

  my $len_diff = length($rec);
  $len_diff -= length($old_deferred) if defined $old_deferred;
  $self->{deferred_s} += $len_diff;
  $self->{cache}->adj_limit(-$len_diff);
  if ($self->{deferred_s} > $self->{dw_size}) {
    $self->_flush;
  } elsif ($self->_cache_too_full) {
    $self->_cache_flush;
  }
}

# Remove a single record from the deferred-write buffer without writing it
# The record need not be present
sub _delete_deferred {
  my ($self, $n) = @_;
  my $rec = delete $self->{deferred}{$n};
  return unless defined $rec;

  if (defined $self->{deferred_max} 
      && $n == $self->{deferred_max}) {
    undef $self->{deferred_max};
  }

  $self->{deferred_s} -= length $rec;
  $self->{cache}->adj_limit(length $rec);
}

sub FETCHSIZE {
  my $self = shift;
  my $n = $self->{eof} ? $#{$self->{offsets}} : $self->_fill_offsets;

  my $top_deferred = $self->_defer_max;
  $n = $top_deferred+1 if defined $top_deferred && $n < $top_deferred+1;
  $n;
}

sub STORESIZE {
  my ($self, $len) = @_;

  if ($self->{autodefer}) {
    $self->_annotate_ad_history('STORESIZE');
  }

  my $olen = $self->FETCHSIZE;
  return if $len == $olen;      # Woo-hoo!

  # file gets longer
  if ($len > $olen) {
    if ($self->_is_deferring) {
      for ($olen .. $len-1) {
        $self->_store_deferred($_, $self->{recsep});
      }
    } else {
      $self->_extend_file_to($len);
    }
    return;
  }

  # file gets shorter
  if ($self->_is_deferring) {
    # TODO maybe replace this with map-plus-assignment?
    for (grep $_ >= $len, keys %{$self->{deferred}}) {
      $self->_delete_deferred($_);
    }
    $self->{deferred_max} = $len-1;
  }

  $self->_seek($len);
  $self->_chop_file;
  $#{$self->{offsets}} = $len;
#  $self->{offsets}[0] = 0;      # in case we just chopped this

  $self->{cache}->remove(grep $_ >= $len, $self->{cache}->ckeys);
}

### OPTIMIZE ME
### It should not be necessary to do FETCHSIZE
### Just seek to the end of the file.
sub PUSH {
  my $self = shift;
  $self->SPLICE($self->FETCHSIZE, scalar(@_), @_);

  # No need to return:
  #  $self->FETCHSIZE;  # because av.c takes care of this for me
}

sub POP {
  my $self = shift;
  my $size = $self->FETCHSIZE;
  return if $size == 0;
#  print STDERR "# POPPITY POP POP POP\n";
  scalar $self->SPLICE($size-1, 1);
}

sub SHIFT {
  my $self = shift;
  scalar $self->SPLICE(0, 1);
}

sub UNSHIFT {
  my $self = shift;
  $self->SPLICE(0, 0, @_);
  # $self->FETCHSIZE; # av.c takes care of this for me
}

sub CLEAR {
  my $self = shift;

  if ($self->{autodefer}) {
    $self->_annotate_ad_history('CLEAR');
  }

  $self->_seekb(0);
  $self->_chop_file;
    $self->{cache}->set_limit($self->{memory});
    $self->{cache}->empty;
  @{$self->{offsets}} = (0);
  %{$self->{deferred}}= ();
    $self->{deferred_s} = 0;
    $self->{deferred_max} = -1;
}

sub EXTEND {
  my ($self, $n) = @_;

  # No need to pre-extend anything in this case
  return if $self->_is_deferring;

  $self->_fill_offsets_to($n);
  $self->_extend_file_to($n);
}

sub DELETE {
  my ($self, $n) = @_;

  if ($self->{autodefer}) {
    $self->_annotate_ad_history('DELETE');
  }

  my $lastrec = $self->FETCHSIZE-1;
  my $rec = $self->FETCH($n);
  $self->_delete_deferred($n) if $self->_is_deferring;
  if ($n == $lastrec) {
    $self->_seek($n);
    $self->_chop_file;
    $#{$self->{offsets}}--;
    $self->{cache}->remove($n);
    # perhaps in this case I should also remove trailing null records?
    # 20020316
    # Note that delete @a[-3..-1] deletes the records in the wrong order,
    # so we only chop the very last one out of the file.  We could repair this
    # by tracking deleted records inside the object.
  } elsif ($n < $lastrec) {
    $self->STORE($n, "");
  }
  $rec;
}

sub EXISTS {
  my ($self, $n) = @_;
  return 1 if exists $self->{deferred}{$n};
  $n < $self->FETCHSIZE;
}

sub SPLICE {
  my $self = shift;

  if ($self->{autodefer}) {
    $self->_annotate_ad_history('SPLICE');
  }

  $self->_flush if $self->_is_deferring; # move this up?
  if (wantarray) {
    $self->_chomp(my @a = $self->_splice(@_));
    @a;
  } else {
    $self->_chomp1(scalar $self->_splice(@_));
  }
}

sub DESTROY {
  my $self = shift;
  $self->flush if $self->_is_deferring;
  $self->{cache}->delink if defined $self->{cache}; # break circular link
  if ($self->{fh} and $self->{ourfh}) {
      delete $self->{ourfh};
      close delete $self->{fh};
  }
}

sub _splice {
  my ($self, $pos, $nrecs, @data) = @_;
  my @result;

  $pos = 0 unless defined $pos;

  # Deal with negative and other out-of-range positions
  # Also set default for $nrecs 
  {
    my $oldsize = $self->FETCHSIZE;
    $nrecs = $oldsize unless defined $nrecs;
    my $oldpos = $pos;

    if ($pos < 0) {
      $pos += $oldsize;
      if ($pos < 0) {
        croak "Modification of non-creatable array value attempted, subscript $oldpos";
      }
    }

    if ($pos > $oldsize) {
      return unless @data;
      $pos = $oldsize;          # This is what perl does for normal arrays
    }

    # The manual is very unclear here
    if ($nrecs < 0) {
      $nrecs = $oldsize - $pos + $nrecs;
      $nrecs = 0 if $nrecs < 0;
    }

    # nrecs is too big---it really means "until the end"
    # 20030507
    if ($nrecs + $pos > $oldsize) {