view release on metacpan or  search on metacpan

lib/FlatFile/DataStore.pm  view on Meta::CPAN

    }

    my $datafile = $self->which_datafile( $fnum );
    my $datafh   = $self->locked_for_read( $datafile );
    my $preamble = $self->read_preamble( $datafh, $seekpos );

    # if we got the record via key file, check that preambles match
    if( $keystring ) {

        croak qq/Mismatch: "$preamble" ne "$keystring"/
            if $preamble ne $keystring;
    }

    # if not via key file, we still need the record length
    else {
        my $parms  = $self->burst_preamble( $preamble );
        $reclen  = $parms->{'reclen'};
    }

    $seekpos += $self->preamblelen;  # skip to record data

    sysseek $datafh, $seekpos, 0 or

        croak qq/Can't seek to $seekpos in $datafile: $!/;

    return $datafh, $seekpos, $reclen;
}

#---------------------------------------------------------------------

=head2 update( $record )

 or update( { string => $preamble_string, data => \$record_data, user => $user_data } )
 or update( { preamble => $preamble_obj, data => \$record_data, user => $user_data } )
 or update( { record => $record_obj
    [, preamble => $preamble_obj]
    [, string   => $preamble_string]
    [, data     => \$record_data]
    [, user     => $user_data] } )

Updates a record. If the parameter is a record object,
the preamble, record data, and user data will be gotten
from it.  Otherwise, if the parameter is a hash reference,
the expected keys are:

 - record   => FlatFile::DataStore::Record object
 - preamble => FlatFile::DataStore::Preamble object
 - string   => a preamble string (the string attribute of a preamble object)
 - data     => string or scalar reference
 - user     => string

If no record is passed, 'preamble' (or 'string'), 'data', and
'user' are required.  Otherwise, if a record is passed, the
preamble, record data and user data will be gotten from it
unless any of them are explicitly provided.

Returns a Flatfile::DataStore::Record object.

=cut

sub update {
    my $self = shift;
    my( $data_ref, $user_data, $pr_obj ) = $self->normalize_parms( @_ );

    croak qq/Must have at least a previous preamble for update/
        unless $pr_obj;

    my $prevnext = $self->prevfnum;  # boolean

    my $prevpreamble = $pr_obj->string;
    my $keyint       = $pr_obj->keynum;
    my $prevind      = $pr_obj->indicator;
    my $prevfnum     = $pr_obj->thisfnum;
    my $prevseek     = $pr_obj->thisseek;

    # update is okay for these:
    my $create = $self->crud->{'create'};
    my $update = $self->crud->{'update'};
    my $delete = $self->crud->{'delete'};

    croak qq/update not allowed: $prevind/
        unless $prevind =~ /[\Q$create$update$delete\E]/;

    # get keyfile
    #   need to lock files before getting seek positions
    #   want to lock keyfile before datafile

    my( $keyfile, $keyfint ) = $self->keyfile( $keyint );
    my $keyfh                = $self->locked_for_write( $keyfile );
    my $keyseek              = $self->keyseek( $keyint );

    my $try = $self->read_preamble( $keyfh, $keyseek );

    croak qq/Mismatch: "$try" ne "$prevpreamble"/ unless $try eq $prevpreamble;

    # get datafile ($datafnum may increment)
    my $top_toc  = $self->new_toc( { int => 0 } );
    my $datafnum = int2base $top_toc->datafnum, $self->fnumbase, $self->fnumlen;
    my $reclen   = length $$data_ref;

    my $datafile;
    ( $datafile, $datafnum ) = $self->datafile( $datafnum, $reclen );
    my $datafh               = $self->locked_for_write( $datafile );
    my $dataseek             = -s $datafile;  # seekpos into datafile

    # get next transaction number
    my $transint = $self->nexttransnum( $top_toc );

    # make new record
    my $preamble_hash = {
        indicator => $update,
        transind  => $update,
        date      => now( $self->dateformat ),
        transnum  => $transint,
        keynum    => $keyint,
        reclen    => $reclen,
        thisfnum  => $datafnum,
        thisseek  => $dataseek,
        user      => $user_data,
        };
    if( $prevnext ) {

lib/FlatFile/DataStore.pm  view on Meta::CPAN

# and seek pos for reading a record.
# 
# Private method.
# 
# =cut
# 

sub burst_preamble {
    my( $self, $string ) = @_;

    croak qq/No preamble to burst/ unless $string;

    my @fields = $string =~ $self->regx;

    croak qq/Something is wrong with preamble: $string/ unless @fields;

    my %parms;
    my $i;
    for( $self->specs ) {  # specs() returns an array of hashrefs
        my( $key, $aref )       = %$_;
        my( $pos, $len, $parm ) = @$aref;
        my $field = $fields[ $i++ ];
        for( $key ) {
            if( /indicator|transind|date/ ) {
                $parms{ $key } = $field;
            }
            elsif( /user/ ) {
                my $try = $field;
                $try =~ s/\s+$//;
                $parms{ $key } = $try;
            }
            elsif( /fnum/ ) {
                next if $field =~ /^-+$/;
                $parms{ $key } = $field;
            }
            else {
                next if $field =~ /^-+$/;
                $parms{ $key } = base2int( $field, $parm );
            }
        }
    }
    return \%parms;
}

#---------------------------------------------------------------------
# 
# =head2 update_preamble()
# 
# Called by update() and delete() to flag old recs.
# 
# Takes a preamble string and a hash ref of values to change, and
# returns a new preamble string with those values changed.
# 
# Will croak if the new preamble does not match the regx attribute.
# 
# Private method.
# 
# =cut
# 

sub update_preamble {
    my( $self, $preamble, $parms ) = @_;

    my $omap = $self->specs;

    for( keys %$parms ) {

        my $value = $parms->{ $_ };

        my $specs = omap_get_values( $omap, $_ );
        croak qq/Unrecognized field: $_/ unless $specs;

        my( $pos, $len, $parm ) = @{$specs};

        my $try;
        if( /indicator|transind|date|user/ ) {
            $try = sprintf "%-${len}s", $value;

            croak qq/Invalid value for $_: $try/
                unless $try =~ $Ascii_chars;
        }
        # the fnums should be in their base form already
        elsif( /fnum/ ) {
            $try = sprintf "%0${len}s", $value;
        }
        else {
            $try = int2base $value, $parm, $len;
        }

        croak qq/Value of $_ too long: $try/ if length $try > $len;

        substr $preamble, $pos, $len, $try;  # update the field
    }

    croak qq/Something is wrong with preamble: $preamble/
        unless $preamble =~ $self->regx;

    return $preamble;
}

#---------------------------------------------------------------------
# file read/write:
#---------------------------------------------------------------------

#---------------------------------------------------------------------
# 
# =head2 locked_for_read()
# 
# Takes a file name, opens it for input, locks it, sets binmode, and
# returns the open file handle.
# 
# Private method.
# 
# =cut
# 

sub locked_for_read {
    my( $self, $file ) = @_;
    untaint path => $file;

    my $fh;