view release on metacpan or  search on metacpan

Persistent.pm  view on Meta::CPAN

# set to 1 to store new values back to disk after changes
$Autosync = 0;

# set to 1 to use Data::Dumper
$Readable = 0;

# format of backup file
$BackupFile = sub { "$_[0]~" };

# format of numbered backup file
$NumberedBackupFile = sub { "$_[0]~$_[1]~" };

#
# all tie constructors delegate the work to the common '_new'
#
sub TIEHASH {
  my $class = shift;
  unshift @_, 'HASH';
  unshift @_, "${class}::Hash";

  goto &_new;
}

sub TIEARRAY {
  my $class = shift;
  unshift @_, 'ARRAY';
  unshift @_, "${class}::Array";

  croak "TIEARRAY not supported prior to perl v5.005"
    if $] < 5.005;

  goto &_new;
}

sub TIESCALAR {
  my $class = shift;
  unshift @_, 'SCALAR';
  unshift @_, "${class}::Scalar";

  goto &_new;
}

#
# import for easier reading
#
*ISA = \&UNIVERSAL::isa;

#
# as suggested by Mark-Jason Dominus
# now we don't have to copy those object data back into the tie...
#
sub Rebind::TIEHASH { $_[1] }

#
# main workhorse
#
sub _new {
  my ($class, $type, $file, $mode, $other) = @_;
  my $self = [];
  bless $self => $class;
  $mode = lc($mode);
  $self->[1]  = $type;		# keep for easier DESTROY
  $self->[2]  = $file;		# must be given
  $self->[3]  = $mode || 'r';	# mode defaults to read-only
  $self->[4]  = $Autosync;      # default to global

  croak "No filename specified"
    if not defined $file;

  use vars qw($PersistentData);
  # used in 'do' to read data stored with Data::Dumper
  local ($PersistentData);

  if ($mode =~ m/[ra+]/) {
    # not write-only, we may have to read data back in...
    if (not -f $file) {
      # cannot read-only (or append) from non-existing file
      croak "Cannot find file $file"
	if (not $mode =~ m/[w+]/);
    } else {
      # file exists; check if we later can write it back
      if ($mode =~ m/[w+a]/) {
	my $fdir = dirname($file);
	croak "Data file dir $fdir is not writeable"
	  if (not -w $fdir);
	croak "Data file $file is not writeable"
	  if (-f $file and not -w $file);
      }

      # now read; first try Storable...
      eval { $PersistentData = retrieve($file) };
      if (not defined $PersistentData) {
	# nope, now try Data::Dumper...
	open FILE, $file
	  or croak "Cannot open file $file: $!";
	my $firstline = <FILE>;
	close FILE;
	# check filetype
	croak "File $file is not a PersistentData file"
	  if (substr($firstline, 0, 15) ne '$PersistentData');
	# let the perl parser do the work for us
	do $file;
      }
      croak "Cannot load file $file: $@"
	if $@;
      confess "?? PersistentData is not a ref "
	if not defined ref($PersistentData);
    }
  }

  # do we have to chain another var in?
  my $objtype;
  my $tied;
  if (defined $other) {
    if (ref $other) {
      croak "Reference is not a $type"
	if not ref($other) eq $type;
      $self->[0] = $other;
    } else {
      $objtype = $other;