File Coverage

blib/lib/Persistence/Object/Simple.pm

Criterion	Covered	Total	%
statement	15	126	11.9
branch	0	62	0.0
condition	0	32	0.0
subroutine	5	15	33.3
pod	8	10	80.0
total	28	245	11.4

#!/usr/bin/perl -s
##
## Persistence::Object::Simple -- Persistence For Perl5 Objects.
##
## $Date: 1999/10/13 23:08:43 $
## $Revision: 0.47 $
## $State: Exp $
## $Author: root $
##
## Copyright (c) 1998, Vipul Ved Prakash.  All rights reserved.
## This code is free software; you can redistribute it and/or modify
## it under the same terms as Perl itself.

package Persistence::Object::Simple;
use Digest::MD5;
use Data::Dumper;
use Carp;
use Fcntl;
use vars qw( $VERSION );

( $VERSION )  = '$Revision: 0.92 $' =~ /\s+(\d+\.\d+)\s+/;  #-- Module Version

my $DOPE      = "/tmp";     #-- The default Directory Of Persistent Entities
my $MAXTRIES  = 250;        #-- TTL counter for generating a unique file

sub dope {                  #-- Default DOPE access method

    my ( $self, $dope ) = @_;
    ${ $self->{ __DOPE } } = $dope if $dope;
    ${ $self->{ __DOPE } };

}

sub new {                   #-- Constructor.  Creates and inits a P::O::S
                            #-- object instance. Binds class data.

    my ( $class, %args ) = @_;
    my $self = {};
    my $fn = $args{ __Fn };
    my $exists;
	$args{ __Create } ||= "";
    if ($args{ __Create } and lc($args{ __Create }) eq "no") {
        $exists = 1;
    }

    return undef if !(-e $fn) && $exists;
    unless ( $fn ) {
        $fn = $class->uniqfile ( $args{ __Dope } || $DOPE, $args{ __Random } );
        return undef unless $fn;
    }

    $self->{ __Fn } = $fn;
    $self->{ __DOPE } = \$DOPE;


    my $existing = $class->load ( __Fn => $fn );
    $self = $existing if $existing;
    for ( keys %args ) { $self->{ $_ } = $args{ $_ } }

    bless $self, $class;

}

sub dumper {                #-- Returns the Data::Dumper object associated
                            #-- with the instance
    my $self = shift;

    $self->{ __Dumper } = new Data::Dumper ( [ $self ] );
    return $self->{ __Dumper };

}

sub commit {                #-- Commits the object to disk.  Works as a class
                            #-- method as well.
    my ( $self, %args ) = @_;
    my $class = ref $self || $self;
    my ( $d, $fn );
    $fn = $args{ __Fn }  || $self->{ __Fn };

    if ( ref $self ) {
        $d = $self->{ __Dumper } || $self->dumper () ;
    } else {  # -- Whoa! It's a class method!
        $d = new Data::Dumper ( [ $args{ Data } ] );
    }

    if ( $args{ __Dope } && $fn ) {  # -- change to a new dope
            $fn =~ s:.*/::;
            $args{ __Dope } =~ s:/$::;
            $fn = $args{ __Dope } . "/$fn";
            croak "$fn exists. Can't overwrite." if -e $fn;
    }

    unless ( $fn ) {  # -- generate a uniq filename in the
        $args{ __Dope } = $DOPE unless $args{ __Dope }; # -- new dope
        $fn = $class->uniqfile ( $args{ __Dope } );
    }


    my $locked_fh = $self->{ __Lock };
    seek $locked_fh, 0, 0 if $locked_fh;
    my $fh;

    # -- delete extra object data and class data-refs if this looks like
    # -- an object.
    if ( ref $self ) {
        for ( keys %$self ) { delete $self->{ $_ }
            if /^__(?:Dumper|DOPE|Fn|Lock|Create)/ };
    }

    unless ( $locked_fh ) {
        # guard against disallowed characters in filename (basically those
        # which might mess up the open() call)
        if (($fn) = ($fn =~ /^([^<>|+]+)$/)) {
            open C, ">$fn" || croak "Can't open $fn for writing.";
            eval { flock C, 2 }; undef $@;
            $fh = *C{ IO };
        } else {
            die "Filename '$fn' contains inappropriate characters";
        }
    }

    print { $locked_fh ? $locked_fh : $fh }
	defined &Data::Dumper::Dumpxs ? $d->Dumpxs() : $d->Dump();
    close $fh if $fh;

    if ( ref $self ) {
        $self->{ __Fn } = $fn;
        $self->{ __Lock } = $locked_fh if $locked_fh;
    }

    return $fn;

}

sub load {

    my ( $class, %args ) = @_;

    return undef unless -e $args{ __Fn };

    open C, $args{ __Fn } || croak "Couldn't open $args{ __Fn }.";
    eval { flock C, 2 }; undef $@;

    local $/ = undef; # slurp mode
    my $objectfile = ;
    close C;

    # untaint the input meaningfully
    if ($objectfile =~ /^(\$VAR1 = bless[^;]+;)$/s) {
        my $object = eval "$1";
        croak "$args{ __Fn } is corrupt. Object loading aborted." if $@;

        $object->{ __Fn } = $args{ __Fn } if ref $object eq 'HASH';
        return $object;
    } elsif ($objectfile =~ /^$/) {
        return undef;
    } else {
        croak "Tainted data from $args{__Fn} looks unsafe. Object loading aborted.";
    }
}

sub expire {

    my ( $self ) = @_;
    my $fn = $self->{ __Fn };
    return 1 if unlink $fn;

}

sub move {

    my ( $self, %args ) = @_;
    my   $class = ref $self;

    $self->expire ();
    $self->{ __Fn } = undef if $args{ __Fnalter };
    my $fn = $self->commit ( %args );

    my $moved = $class->new ( __Fn => $fn );
    $self = $moved;

}

sub lock {

    my ( $self ) = @_;

    my $fn = $self->{ __Fn };
	$self->commit unless -e $fn;
    open ( F, "+<$fn" ) || croak "Couldn't open $fn for locking. Commit first!";
    eval { flock F, 2 }; undef $@;
    $self->{ __Lock } = *F{ IO };

}

sub unlock {

    my ( $self ) = @_;
    my $F = $self->{ __Lock }; close $F;
    undef $self->{ __Lock };

}

sub uniqfile {

    my ( $class, $dir, $random ) = @_;
    my $fn; my $counter;

    do {
        $fn = Digest::MD5::md5_hex( "@{[time]}.@{[int rand 2**8]}.$random" );
        ($fn) = ($fn =~ m!([^/<>|;]+)!);
        $counter++ ;
    }
    until sysopen ( C, "$dir/$fn" , O_RDWR|O_EXCL|O_CREAT )
        or $counter > $MAXTRIES;

    close C;
    return undef if $counter > $MAXTRIES;
    return "$dir/$fn";
}

'True Value';

__END__