MMAgic/Data.pm

Go to the documentation of this file.

package MMAgic::Data;

=head1 NAME

MMAgic::Data - Data object stored as file in Perl data structure.

=head1 SYNOPSIS

    my  $data;
    tie $data, 'MMAgic::Data', '/tmp/some.data';
    
    print $data->{field}->[0], "\n";
    if ( $somethingHasChanged && tied($var)->lock)
        {
        my  $temp = $data;  # cause re-read
        # ...statements...  # make changes
        $data->flush;       # push changes out
        }

=head1 ABSTRACT

Tie variable to contents of data file expressed as Perl data structure.
Fetch and store entire contents.
Use non-tie methods lock() and flush() to update parts of the data structure.

=head1 DESCRIPTION

=head1 CAVEATS

=head2 C<ARRAY>

An attempt was made to add an C<ARRAY> tie but it doesn't work very well.
Maybe someday...

=head2 Opcodes

The C<Safe> module uses opcodes that have changed over time.
Current code is working for Perl 5.8.8.
It will work as far back as 5.006 but may require different opcodes.
The C<allw> flag in the constructor or C<$ENV{MMAgic_Data_allw}> can
be used to override the opcodes.

When opcode issues arise, it is often difficult to figure out which
opcodes to add.
One way is to look up the C<opcode.h> file in the Perl source and
cross-reference C<PL_op_desc[]> (which is what shows up in error
messages at run-time) to C<PL_op_name[]> (which is what is required
for opcode names in the C<allw> list) by array index.

=head1 METHODS

=over

=cut

require 5.006; # 5.003 WILL NOT work due to Safe and fcntl :seek issues.

use strict;
use warnings;

use Fcntl ':seek', ':flock';
use File::Basename;
use Safe;
use Symbol;
use UNIVERSAL   qw(isa);

use MMAgic::File::Status;
use MMAgic::Log;
use MMAgic::Stack;
use MMAgic::Trace;

our $poll  = 300;

# Default allowable opcodes for Safe:
our @allow = qw
    (
    abs
    add i_add
    anonhash
    anonlist
    chr ord
    const
    divide i_divide
    hex int oct
    leaveeval
    length
    lineseq
    list
    modulo i_modulo
    multiply i_multiply
    padany
    pow
    pushmark
    refgen
    scalar
    stub
    subtract i_subtract
    );

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

=item   C<_arg($arg, $init, $dflt)>

Look for intialization parameter.

Check in C<$init> value, then environment variable of the form
C<$ENV{"MMAgic_Data_$arg}>, then C<$dflt> value.

Intended for internal use.

=cut

sub _arg
    {
    my ($arg, $init, $dflt) = @_;
    my  $val = isa($init, 'HASH') && $init->{$arg};
    
    $val = $ENV{"MMAgic_Data_$arg"} unless defined $val;
    $val = $dflt                    unless defined $val;
    $val
    }

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

=item   C<new($class, $path, %init)>

Constructor for MMAgic::Data object.

    Flags:      (default)   (description)
    ----------------------------------------------------------------------
      * allw     (below)    allowable operations during file eval
      * barf        1       die() if file doesn't exist
      * dpth       15       max depth to store when flushing to file
      * dflt                default value for data if no file
        goto                label in file to skip past before loading
        make                create file if necessary to store data (???)
      * poll      300       time (sec) to wait before checking to see if
                            file has been changed and requires reloading
    ----------------------------------------------------------------------
      * Flag is settable via $ENV{MMAgic_Data_$flag}

=cut

#=| @param  $path   Pathname of data file.
#=| @param  %init   Flags used in object creation

sub new
    {
    my  $class = shift;
    my ($name, $path, $suff) = fileparse(shift, '\.[^\.]*');
#!# my  $auto  = Log->method($class, $path, '%', @_)->block;
    my  %init  = @_;
    my  $self  = bless { }, $class;
    
    $suff = '.data' unless $suff;
    
    $self->{allw} = isa($init{allow}, 'ARRAY') ? $init{allow} : \@allow;
    $self->{barf} = _arg('barf', \%init,  1);
    $self->{dflt} = _arg('dflt', \%init);
    $self->{dpth} = _arg('dpth', \%init, 15);
    $self->{labl} = $init{'goto'};
    $self->{lazy} = $init{'lazy'};
    $self->{make} = $init{'make'};
    $self->{path} = "$path$name$suff";
    $self->{poll} = _arg('poll', \%init, $poll);
    $self->{fsts} =
        new MMAgic::File::Status($path, poll => $self->{poll});

    return $self
        if $self->{lazy};

    $self->fetch && $self
    }

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

=item   C<DESTROY($self)>

Destructor for MMAgic::Data object.

Invokes cleanup() routine.

=cut

sub DESTROY
    {
#!# my  $auto = Log->method($_[1])->block;
#!# MMAgic::Stack::trace(1);
    $_[0]->cleanup;
    }

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

=item   C<cleanup($self)>

Cleanup open file and locks.

Intended for internal use.

=cut

sub cleanup
    {
#!# my  $auto = Log->method($_[1])->block;
    my  $self = shift;
    
    $self->unlock;
        
    if ($self->{handle})
        {
        close $self->{handle};
        undef $self->{handle};
        }
    
    undef
    }

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

=item   C<handle($self, $writable)>

Open file, return file handle.

Intended for internal use.

=cut

sub handle
    {
#!# my  $auto = Log->method($_[1])->block;
    my  $self = shift;
    
    return $self->{handle} if $self->{locked};
    
    my  $writable = shift;
    
    unless ($self->{handle} && ! $writable)
        {
#!#     Log->trace('creating new handle');  #[detail]
        
        if (defined $self->{handle})
            {
            # Open for reading, must be closed
            #   and re-opened for writing:
            close $self->{handle};
            undef $self->{handle};
            }
        
        Log->error('No pathname in Data tie'),
#!#     MMAgic::Stack::trace(3),
        return undef
            unless $self->{path};
        
#!#     Log->trace('check for non-existent data file'); #[detail]
        
        unless ($writable || -e $self->{path})
            {
            Log->crash("Non-existent data file:\n  ", $self->{path})
                if $self->{barf} && ! $self->{dflt};
            
            return undef;
            }
        
        $self->{handle} = gensym;
        
#       my  $mode = ! -e $self->{path} ?  '>' :
#                   $writable          ? '+<' : '<';

        my  $mode = ($writable        ? '+' : '')
                  . (-e $self->{path} ? '<' : '>');
        
#!#     Log->trace('opening file ', $self->{path}); #[detail]
        
        unless (open($self->{handle}, "$mode $self->{path}"))
            {
            Log->crash("Unable to '$mode' open data file:\n    ",
                       $self->{path}, "\n  $!")
                if $self->{barf} && ! $self->{dflt};

            return undef($self->{handle})
            }
        }
    
    $self->{handle}
    }

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

=item   C<_load($self, $handle)>

Load and return data from file open on handle.
Default version does an eval on the file contents
protected by a Safe object with only basic opcodes allowed.

Intended for internal use.

=cut

sub _load
    {
    my  $self   = shift;
#!# my  $auto   = Log->method(@_)->block;
    my  $handle = shift;
    my  $result = undef;
    my  @text;
    
    seek $handle, 0, SEEK_SET;
    
    if (@text = <$handle>)
        {
        if ($self->{labl})
            {
            while (my $text = shift @text)
                {
                chomp $text;
#!#             Log->trace('Skipping:  ', $text),
                last if $text eq $self->{labl};
                }
            }
    
        # Use Safe for evaluation:
        my  $safe = new Safe;
    
        Log->warning("Unable to create Safe object:\n  $!"),
        return undef
            unless new Safe;
        
        $safe->permit_only(@{$self->{allw}});
        $result = $safe->reval(join '', @text);
    
        if ($@)
            {
            undef $result;
            Log->crash("Unable to parse data file:\n    ",
                       $self->{path}, "\n  $@")
                if $self->{barf}
                && ! $self->{dflt};
            }
        
        elsif (! defined $result)
            {
            Log->crash("Unable to execute data file:\n    ",
                       $self->{path}, "\n  $!")
                if $self->{barf}
                && ! $self->{dflt};
            }
        
        elsif (! $self->{type})
            {
            # No pre-specified type to check against.
            }
        
        elsif (! isa($result, $self->{type}))
            {
            undef $result;
            Log->crash("Data file didn't return $self->{type}:\n  ",
                       ref($result), "\n");
            }
        }
    
    elsif ($self->{barf} && ! $self->{dflt})
        {
        Log->crash("No lines of text in data file:\n  ", $self->{path});
#!#     MMAgic::Stack::trace(5),
        }

    $result = $self->{dflt}
        unless defined $result;

    $self->{loaded} = time
        if defined $result;
        
    $result
    }

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

=item   C<fetch($self)>

Fetch data value itself.
Value is a scalar reference.

=cut

sub fetch
    {
    my  $self = shift;
#!# my  $auto = Log->method($self)->block;
    
    # Then check to see if the file has newer data than what we have:
    unless ($self->upToDate)
        {
#!#     Log->trace("Reloading data from:\n    ", $self->{path});   #[reload]
#!#     Log->trace(' no data cached')    unless $self->{data};  #[reload]
#!#     Log->trace(' data file changed') unless $self->{loaded} >= $self->{mtime};  #[reload]
        
        undef $self->{data} if defined $self->{data};
        
        my  $handle = $self->handle;

#!#     Log->trace('Handle:  ', $handle);
        
        Log->warning("Unable to lock data file for reading:\n  ",
                     $self->{path}, "\n  $!"),
        return $self->cleanup,
            unless $self->{locked} || flock($handle, LOCK_SH);
        
        $self->{data} = $self->_load($handle);
    
        # After fetching from the file, close it:
        unless ($self->{locked})
            {
            # If we're a FETCH() nested w/in a pending lock()/flush(),
            #   don't close open file handle or lose the lock!!!
#!#         Log->trace("closing file handle for\n  ", $self->{path});   #[detail]
            close $self->{handle};
            undef $self->{handle};
            }
        }
    
#!# Log->trace('Returning data:  ', $self->{data});
    
    $self->{data}
    }

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

=item   C<flush($self)>

Update current value to backing store.
If it fails, the data remains the same.

=cut

sub flush
    {
#!# my  $auto = Log->method($_[1])->block;
    my  $self = shift;
    
    return undef unless $self->{locked};
    
    # File is open and locked, OK to make changes,
    #   begin by rewinding and truncating (hope this works):
    seek     $self->{handle}, 0, SEEK_SET;
    truncate $self->{handle}, 0;
    
    my  $out = new MMAgic::Output(output => $self->{handle});
    
    $self->cleanup,         # well,
    undef($self->{data}),   #   we're fucked anyway
    return undef
        unless isa($out, 'MMAgic::Output');
    
#!# Log->trace('dumping:')->reference($self->{data});   #[detail]
    
    $out->dumpref($self->{data}, maxDepth => $self->{dpth});
    $out->close;
    undef $out;
        
    $self->cleanup;
    undef $self->{data};    # force re-read next time
    
    1
    }

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

=item   C<loaded($self)>

Return load time if data currently loaded.

=cut

sub loaded
    {
    my  $self = shift;
    
    $self->{data} && $self->{loaded}
    }

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

=item   C<lock($self)>

Lock for (reading and) writing preparatory to making changes.
Next read from variable will return new data.
Return true if successful, C<undef> on failure.

Call using:

    tied($data)->lock;

Note that file is also opened now!!!

=cut

sub lock
    {
#!# my  $auto = Log->method($_[1])->block;
    my  $self = shift;
    
    return 1     if     $self->{locked};
    return undef unless $self->handle(1);
    
    Log->warning("Unable to lock data file for writing:\n  ",
                 $self->{path}, "\n  $!"),
    return $self->cleanup,
        unless flock($self->{handle}, LOCK_EX);
    
#!# Log->trace(' - locked');    #[detail]
    undef $self->{data};    # force re-read next time
    $self->{locked} = 1
    }

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

=item   C<path($self)>

Return the path of the file containing the underlying data.

=cut

sub path
    {
    $_[0]->{path}
    }

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

=item   C<refresh($self)>

Cause underlying data to be refreshed.

=cut

sub refresh
    {
#!# my  $auto = Log->method($_[1])->block;
    my  $self = shift;
    
    return if $self->{locked};

    undef $self->{data} if defined $self->{data};
    }

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

=item   C<store($self, $data)>

Store data into backing file.
Data is undefined in case of error.
New data returned.

=cut

sub store
    {
    my  $self = shift;
#!# my  $auto = Log->method($self)->block;
    my  $data = shift;
    
#!# Log->reference($data);  #[detail]
#!# MMAgic::Stack::trace(3);
    
    Log->warning("Data object undefined during STORE"),
#!# MMAgic::Stack::trace,
    return undef($self->{data})
        unless defined $data;
    
    Log->warning("Data object not a reference"),
    # TBD:  but could it be a scalar?
    return undef($self->{data})
        unless ref $data;
    
    return undef($self->{data})
        unless $self->lock;
    
    $self->{data} = $data;
    
    return undef($self->{data})
        unless $self->flush;
    
    $self->{data}
    }

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

=item   C<unlock($self)>

Release lock on tied object.
Returns without error if not locked.

=cut

sub unlock
    {
    my  $self = shift;
#!# my  $auto = Log->method(@_)->block;
    
    return unless $self->{locked};

    flock($self->{handle}, LOCK_UN);
    close($self->{handle});
    undef $self->{handle};
    undef $self->{locked};
    
    # don't force re-read, this is done in flush(),
    #   which makes sense as there changes have been made
    }

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

=item   C<upToDate($self)>

Return true if the data is current.

=cut

sub upToDate    # $self
    {
    my  $self = shift;
#!# my  $auto = Log->method(@_)->block;

#!# Log->trace('Data:  ', $self->{data});
#!# Log->trace('Load:  ', $self->{loaded});
#!# Log->trace('mTim:  ', $self->{fsts}->mtime);

    return undef unless $self->{data};
    return undef unless $self->{loaded};
    return 1     unless $self->{fsts}->mtime;   # non-sensical?
    
    $self->{loaded} >= $self->{fsts}->mtime
    }

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

sub TIESCALAR   # $class, $path, %init
    {
#!# my  $auto  = Log->method(@_)->block;

    new(@_)
    }

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

sub TIEARRAY    # $class, $path, %init
    {
#!# my  $auto  = Log->method(@_)->block;

    new(@_, type => 'ARRAY')
    }

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

sub CLEAR       # $self, $index
    {
    Log->warning('No array data for CLEAR'),
    return
        unless isa($_[0]->fetch, 'ARRAY');
    
    $_[0]->{data} = [ ]
    }

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

sub DELETE      # $self, $index
    {
    Log->warning('No array data for DELETE'),
    return
        unless isa($_[0]->fetch, 'ARRAY');
    
    delete $_[0]->[$_[1]]
    }

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

sub EXISTS      # $self, $index
    {
    isa($_[0]->fetch, 'ARRAY') && defined $_[0]->[$_[1]]
    }

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

sub EXTEND      # $self, $count
    {
    STORESIZE(@_)
    }

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

sub FETCHSIZE   # $self
    {
    scalar @{$_[0]->fetch}
    }

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

sub POP         # $self
    {
    Log->warning('No array data for POP'),
    return
        unless isa($_[0]->fetch, 'ARRAY');
    
    pop @{$_[0]->{data}}
    }

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

sub PUSH        # $self, $value
    {
    Log->warning('No array data for PUSH'),
    return
        unless isa($_[0]->fetch, 'ARRAY');
    
    push @{$_[0]->{data}}, $_[1]
    }

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

sub SHIFT       # $self
    {
    Log->warning('No array data for SHIFT'),
    return
        unless isa($_[0]->fetch, 'ARRAY');
    
    shift @{$_[0]->{data}}
    }

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

sub SPLICE      # $self, $offset, $length, @list
    {
    my  $self = shift;
    
    Log->warning('No array data for SPLICE'),
    return
        unless isa($self->fetch, 'ARRAY');
    
    splice @{$self->{data}}, @_
    }

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

sub STORESIZE   # $self, $count
    {
    my ($self, $count) = @_;
    
    Log->warning('No array data for STORESIZE'),
    return
        unless isa($self->fetch, 'ARRAY');
    
    push @{$self->{data}}, undef
        while @{$self->{data}} < $count
    }

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

sub UNSHIFT     # $self, $value
    {
    Log->warning('No array data for UNSHIFT'),
    return
        unless isa($_[0]->fetch, 'ARRAY');
    
    unshift @{$_[0]->{data}}, $_[1]
    }

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

sub FETCH       # $self [, $index ]
    {
    my  $self = shift;
    
    return $self->{data}->[$_[0]]
        if isa($self->fetch, 'ARRAY')
        && defined $_[0];
   
    # default version:
    $self->fetch
    }

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

sub STORE       # $self, [ $index, ] $value
    {
    my  $self = shift;
#!# my  $auto = Log->method(@_)->block;
    
    if (isa($self->fetch, 'ARRAY') && $_[1] && $self->{locked})
        {
        $self->{data}->[$_[0]] = $_[1]
        }
    
    else
        {
        $self->store(@_)
        }
    }

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

sub UNTIE       # $self
    {
#!# my  $auto = Log->method($_[1])->block;
    $_[0]->cleanup;
    }

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

1

__END__

=back

=head1 AUTHOR

Marc M. Adkins, L<mailto:Perl@Doorways.org>

=head1 COPYRIGHT AND LICENSE

Copyright 2001-2008 by Marc M. Adkins

=cut