#!/usr/bin/perl
#
# $Header: /Users/claude/fuzz/lib/Genezzo/Block/RCS/RDBlock.pm,v 7.3 2005/09/07 08:33:20 claude Exp claude $
#
# copyright (c) 2003, 2004 Jeffrey I Cohen, all rights reserved, worldwide
#
#
use strict;
use warnings;

package Genezzo::Block::RDBlock;
use Genezzo::Util;
use Genezzo::Block::Std;
use Genezzo::Block::RowDir;

use Tie::Hash;
our @ISA = "Tie::Hash" ;

#use Genezzo::Util;
use Carp;
use warnings::register;

my $doRot13 = 0;

sub _mkrowdir
{
    my ($self, $numelts, $freespace) = @_;

    $self->{numelts}   = $numelts;
    $self->{freespace} = $freespace;

    my @rowdir = ();

    for (my $cnt = 0; $cnt < $self->{numelts}; $cnt++)
    {
        $rowdir[$cnt] = 
            [
              GetRDEntry($self, $cnt)
             ];
    }

    $self->{rowdir} = \@rowdir;

    return 1;
}

sub _init
{
#    whoami;
#    greet @_;
    my $self = shift;

    my %optional = (blocksize => $Genezzo::Block::Std::DEFBLOCKSIZE,
                    pctfree => 30,
                    pctused => 50);
    # should this be pctfree = 10, pctused = 40 ?

    my %args = (%optional,
                @_);

    return 0
        unless (exists($args{refbufstr}));

    $self->{bigbuf}  = $args{refbufstr};

    $self->{rowdir}  = []; # create an empty rowdir

    $self->{numelts} = 0; # total number of elements (valid data rows,
                          # deleted rows, and other non-data elements)
    $self->{freespace} = 0;
    $self->{blocksize} = $args{blocksize};

#    confess "bad blocksize"
#        unless ($self->{blocksize} =~ m/\d+/);

    # absfree: amount of space kept free for future updates.  Inserts
    # succeed as long as freespace > absfree.
    # absused - after block is full, amount of space that must be open
    # before can allow inserts.  Can insert again when freespace >
    # absused.

    # NOTE: make sure number between 0 and 100 
    # XXX : might want to round to integer with POSIX::floor
    # should this be 1..99 vs 0..100?

    if (
        1 
#        || ($args{pctfree} < 0)    # cheaper to test up front 
#        || ($args{pctfree} > 100)  # than call numval...
#        || ($args{pctused} < 0)   
#        || ($args{pctused} > 100)
        ) 
    {
        return 0
            unless (NumVal(
                           name => "pctfree",
                           val  => $args{pctfree},
                           MIN  => 0, MAX => 100));
        return 0
            unless (NumVal(
                           name => "pctused",
                           val  => $args{pctused},
                           MIN  => 0, MAX => 100));

        return 0
            if ($args{pctfree} + $args{pctused} > 100);

    }
    # might want to bottom out pctfree at 10% for table data, but can
    # go to 0% for index data.  
    
    # adjust the blocksize to reflect the header/footer space
    my $adjblocksize    = 
        $args{blocksize} - 
        ($Genezzo::Block::Std::LenHdrTemplate + 
         $Genezzo::Block::Std::LenFtrTemplate);

    $self->{adjblocksize} = $adjblocksize;

    $self->{absfree}    = $adjblocksize * ($args{pctfree} / 100);
    $self->{absused}    = $adjblocksize * ($args{pctused} / 100);
    $self->{can_insert} = 1;
    $self->{compacted}  = 0; # true if compacted out deleted rows

    if ($self->{absfree} < $Genezzo::Block::RowDir::LenRowDirTemplate)
    {
        # need enough free space to insert a zero len entry...
        $self->{absfree} = $Genezzo::Block::RowDir::LenRowDirTemplate;
    }

    my ($blocktype, $numelts, $freespace) = GetStdHdr($self);

#    whoami $blocktype, $numelts, $freespace;

    $self->{blocktype} = $Genezzo::Block::Std::BlockType{RandomBlock};
 
    if ($Genezzo::Block::Std::BlockType{EmptyBlock} == $blocktype)
    {
        $self->{freespace}  = $adjblocksize;
        $self->{can_insert} = ($self->{freespace} > $self->{absfree});
        return 1;
    }

    unless ($Genezzo::Block::Std::BlockType{RandomBlock} == $blocktype)
    {
        my $tstr = "UNKNOWN";

        carp "Invalid Block Type - $blocktype : $tstr - not RandomBlock "
            if warnings::enabled();
       return 0;
    }
    $self->{can_insert} = ($freespace > $self->{absfree});
#    return $self->_mkrowdir( $numelts, $freespace);
    return _mkrowdir($self, $numelts, $freespace);
}

# originally, I thought this could be an array, but deleting from an
# array (via SHIFT or POP) never leaves a "hole", it just shifts the
# array entries around so they are always consecutively numbered from
# [0..n].  For a row directory block, each entry must keep its index,
# so deleted entries leave gaps.
sub TIEHASH
{ #sub new
#    greet @_;
    my $invocant = shift;
    my $class = ref($invocant) || $invocant ; 
    my $self = { };

    my %args = (@_);

    return undef
        # XXX: can't call self on unblessed reference here
        unless (_init($self, %args));

    unless ($self->{numelts})
    {
        my @foo;

        if (exists($args{blocknum}))
        {
            my $blockno = $args{blocknum};
            $self->{blocknum} = $blockno;

            # XXX XXX: add a comment in the metadata for testing...
            $foo[0] = "#:META blocknum $blockno";
        }

        # XXX XXX: Note - by default, row zero is metadata, unless
        # "nometazero" flag is set (for certain tests like Block1, Row1)
        unless (exists($args{nometazero}))
        {
            my $pstat = _push_one($self, 
                                  PackRow(\@foo), 0);
            return undef
                unless (defined($pstat));
        }
    }

    my $new_self = bless $self, $class;

    # check if we have any mail
    if (exists($args{MailBag}))
    {
        my $msglist = Genezzo::Util::CheckMail(MailBag => $args{MailBag},
                                               Address => __PACKAGE__);
        if (defined($msglist)
            && scalar(@{$msglist}))
        {
            for my $msg (@{$msglist}) # check all msgs
            {
                # RSVP to sender

                if (exists($msg->{Msg})
                    && exists($msg->{From})
                    && $msg->{Msg} eq 'RSVP')
                {
                    my $sender = $msg->{From};
                    $sender->RSVP(name  => __PACKAGE__,
                                  value => $new_self);
                }
            } # end fo
        }
    } # end if mailbag

    return $new_self

} # end new

our %RowStats = (
                deleted => 0x01, # set if row is deleted
                data    => 0x02, # set for data rows, unset for metadata
                lock    => 0x04, # row is locked, requires metadata
                                 # to identify locker
                head    => 0x08, # 1st piece of a (potentially) multipart row
                tail    => 0x10, # last piece of (potentially) multipart row
                isnull  => 0x20  # if packed value was just an UNDEF
                );

our $DATAROW    = $RowStats{data} | $RowStats{head} | $RowStats{tail}; 
# XXX: note - not a class or instance method
sub _isnull
{
    my $rowstat = shift @_;

    return ($rowstat & $RowStats{isnull})
}
sub _isvaldatarow
{
    my $rowstat = shift @_;

    return (_isdatarow($rowstat) && !_isdeletedrow($rowstat));
}
sub _isdatarow
{
    my $rowstat = shift @_;

    return ($rowstat & $RowStats{data});
}
sub _isdeletedrow
{
    my $rowstat = shift @_;

    return ($rowstat & $RowStats{deleted});
}
sub _isheadrow
{
    my $rowstat = shift @_;

    return (_isvaldatarow($rowstat) && ($rowstat & $RowStats{head}));
}
sub _istailrow
{
    my $rowstat = shift @_;

    return (_isvaldatarow($rowstat) && ($rowstat & $RowStats{tail}));
}

# XXX: note - not a class or instance method
sub _row_write
{
    my $value = shift;

    if ($doRot13)
    {
        $value =~ tr/A-Za-z/N-ZA-Mn-za-m/; # rot13 encryption
    }
    return $value;
#    my $packout = pack('n/a*', $value);
#    return $packout;
}

sub _row_read
{
    my ($rowposn, $rowlen, $refbufstr) = @_;

#    my @baz = unpack("x$rowposn n/a", $$refbufstr);
    my @baz = unpack("x$rowposn a$rowlen", $$refbufstr);

    return undef # XXX XXX: error!
        unless (scalar(@baz) > 0);

    my $value = $baz[0];

    if ($doRot13)
    {
        $value =~ tr/A-Za-z/N-ZA-Mn-za-m/; # rot13 encryption
    }
    return ($value);
}


sub _realfetch
{
    my ($self, $rowposn, $rowlen) = @_;

    my $refbufstr = $self->{bigbuf};

    # skip rowposn bytes then unpack rowlen bytes

    # XXX XXX: remember to fix packdeleted and RDBlock subclasses to
    # support rowlen
    return (_row_read($rowposn, $rowlen, $refbufstr));
}

# get and set metadata in a standard packed row format. value is a
# reference to an array
#
# Each row is identified by a unique id, not the standard 
# array offset (place).  Some example id's are "#" for comments, 
# "I" for indexes.
#
sub _get_meta_row
{
    my ($self, $id) = @_;

    my $place = $self->_fetchmeta($id);

    return undef
        unless (defined($place));
    
    my $fetched = $self->_fetchmeta(undef, $place);

    return undef
        unless (defined($fetched));

    my @row = UnPackRow($fetched, $Genezzo::Util::UNPACK_TEMPL_ARR);  

    return \@row;
}

sub _set_meta_row
{
    my ($self, $id, $value) = @_;

    my $place = $self->_fetchmeta($id);

    if (defined($place))
    {
        # store into the existing metadata row
        my $stat = $self->_realstore($place, 
                                     PackRow($value));   
        return undef
            unless (defined($stat));

        return $value;
    }
    else # no such row
    {
        # XXX XXX: slight hack -- "standard" blocks all have a
        # metadata row for row zero, but some test functions use
        # nonstandard blocks.  Create a row zero for this case if
        # necessary.
        my $numelts =  $self->{numelts};

#        my $stat = $self->_fetchmeta(undef, 0);
#        unless (defined($stat))
        unless ($numelts)
        {
            # no rows found
            greet "no meta zero!";

            # XXX XXX: should be able to use an empty row without
            # a comment...
            $place = $self->_push_one(PackRow(["#:empty"]), 0);

            unless (defined($place) && (!$place))
            {
                whisper "bad push";
                return undef;
            }
        }

        $place = $self->_push_one(PackRow($value), 0);
#        greet "new $place";
    }
    
    return undef 
        unless (defined($place));
    
    # use row zero to find the location of this metarow
    my $stat = $self->_update_meta_zero($id, $place);

    return undef
        unless (defined($stat));

    return $value;
}

# treat row zero as metadata row, an array of scalars identified by a
# unique id.  If the id does not exist, it is added.
#
# value is a scalar, not an array.
#
# NOTE: major assumption - that row zero exists and is a metadata row.
#
sub _update_meta_zero
{
    my ($self, $id, $value) = @_;
    my $oldvalue;
    my $place = 0;

    my $refrowdir = $self->{rowdir};

    my $numelts =  $self->{numelts};

    carp "no zero row for metadata!"
        unless ($numelts);

#  Carp::croak ("No such row")
    return (undef)
        unless ($place < $numelts);

    my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$place] };

    # XXX XXX: need to check if rowstat = metadata ...
    # return undef if rowstat?

    my @row;
    my $appendval = 1; # always append

  L_findcol:
    unless (_isnull($rowstat))
    {
        my $fetched = $self->_realfetch ($rowposn, $rowlen );

        last L_findcol
            unless (defined($fetched));

        @row = UnPackRow($fetched, $Genezzo::Util::UNPACK_TEMPL_ARR);

#        greet @row;

        my $regex = '^' . $id . ':(.*)';

        # XXX XXX: better to do a binary search of sorted array.
        for my $i (0..(scalar(@row)-1))
        {
            my $col = $row[$i];
            my @outi;
            if (@outi = ($col =~ m/$regex/))
            {
                $oldvalue = $outi[0];
                $appendval = 0;
                $row[$i] = $id . ':' . $value;
                last L_findcol;
            }
        }
    }  # end unless

    # XXX XXX: would be better to maintain a sorted array
    if ($appendval)
    {
        push @row, $id . ':' . $value;
    }

#    greet @row;

    my $stat = $self->_realstore($place, PackRow(\@row));

#    greet $stat;
    return undef
        unless (defined($stat));

    # return id and the oldvalue, since the oldvalue might be null...
    return [$id, $oldvalue];
} # end update_meta_zero

# fetch a metadata row either by id or place.  Fetch by id assumes
# valid metadata in row zero.
sub _fetchmeta
{
    my ($self, $id, $mplace) = @_;

    my $place = 0;

    if (!defined($id) && (defined($mplace)))
    {
        # metadata id not defined, so fetch a specific row by place
        # number
        $place = $mplace;
    }

    my $refrowdir = $self->{rowdir};

    my $numelts =  $self->{numelts};

#  Carp::croak ("No such row")
    return (undef)
        unless ($place < $numelts);

    my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$place] };

    return undef
        if (_isnull($rowstat));

    my $fetched = $self->_realfetch ($rowposn, $rowlen );

#    greet $fetched;

    return undef
        unless (defined($fetched));

    # if id is undefined, we have fetched the metadata for mplace

    return ($fetched)
        unless (defined($id)); # no metadata id

    # id was defined, so current row is row zero -- unpack it and find
    # the row associated with the id.

    my @row = UnPackRow($fetched, $Genezzo::Util::UNPACK_TEMPL_ARR);

#    greet @row;

    my $regex = '^' . $id . ':(.*)';

    # XXX XXX: better to do a binary search of sorted array.
    for my $col (@row)
    {
        my @outi;
        if (@outi = ($col =~ m/$regex/))
        {
#            greet @outi;
            return $outi[0];
        }
    }
    return undef;
} # end _fetchmeta

# return rowstat
sub _fetch2
{
#    whoami ();
    my ($self, $place) = @_;

    return (undef)
        unless ($self->EXISTS($place));

    my $refrowdir = $self->{rowdir};
      
    my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$place] };

    return undef
        if (_isnull($rowstat));

    my @outi;
    my $f1 = $self->_realfetch ($rowposn, $rowlen );
    
    $outi[0] = $f1;
    $outi[1] = $rowstat;

    return @outi;
} # end fetch2

sub FETCH
{
#    whoami ();
    my ($self, $place) = @_;

    return (undef)
        unless ($self->EXISTS($place));

    my $refrowdir = $self->{rowdir};
      
    my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$place] };

    return undef
        if (_isnull($rowstat));

    return ($self->_realfetch ($rowposn, $rowlen ));
}

# XXX: note - not a class or instance method
sub _calctotalheader
{
    my $numelts = shift @_;

    return ($Genezzo::Block::Std::LenHdrTemplate + 
            ($numelts * $Genezzo::Block::RowDir::LenRowDirTemplate));
}

sub _spacecheck
{
    my ($self, $packlen) = @_;

    if (defined($packlen))
    {
        return ($self->{absfree} <
                ($self->{freespace} -
                 ($packlen + $Genezzo::Block::RowDir::LenRowDirTemplate)));
    }

    return ($self->{freespace} - 
            ($self->{absfree} +
             $Genezzo::Block::RowDir::LenRowDirTemplate));
}

# XXX: may want to reuse deleted slots at some point
# undef for failure, else return row index
sub _push_one 
{
#    whoami @_;
    my ($self, $value, $rowtype) = @_;

    my $refrowdir = $self->{rowdir};
    my $numelts   = $self->{numelts};

    # XXX XXX XXX
    # NOTE : need to define undef specially
    unless (defined($value))
    {
        $value = "";
        $rowtype |= $RowStats{isnull};
    }

    my $packout = _row_write($value);
    my $packlen = length($packout);

    my $refbufstr = $self->{bigbuf};

    my $nextpos = $self->{blocksize} - $packlen;

    $nextpos -= $Genezzo::Block::Std::LenFtrTemplate;

    if ($numelts)
    {
        # need cnt-1 for rowdir array -- get the final entry and
        # use it to calculate where the next row goes
        my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$numelts - 1] };
        
        $nextpos = $rowposn - $packlen;
    }
    else
    {
        # no holes for deleted rows if started at zero
        $self->{compacted} = 1; # cleaned up as much as possible
    }

#    Carp::croak ("no more room")
    return (undef)
        if ($nextpos <= _calctotalheader($numelts));

    # decrement the freespace
    $self->{freespace} -= 
        ($packlen + $Genezzo::Block::RowDir::LenRowDirTemplate);

    $self->{can_insert} = ($self->{freespace} > $self->{absfree});    

#    whisper "$self->{freespace} bytes freespace remaining";
#    whisper "%free exceeded"
#        unless ($self->{can_insert});

    # add row to block
    substr($$refbufstr, $nextpos, $packlen) = $packout;
    
    # add row to row dir - note that array starts with zero, so we
    # use the unincremented rowcount to add the new row, i.e array
    # of size N={numelts} is [0..(N-1)]
    
    $refrowdir->[$numelts] = [$rowtype, $nextpos, $packlen ];
    $self->{numelts} += 1;

#       greet $refrowdir;

    # still use unincremented row count for new row

    SetRDEntry($self, $numelts,  @{ $refrowdir->[$numelts] } );
    
    # add new row count to main header
    SetStdHdr($self, $self->{blocktype}, $self->{numelts}, $self->{freespace});

    return ($self->{numelts} - 1);

}

# SuckHash::Split::
# HSuck(array value)
#
# returns null if cannot consume the value, 
# else returns new key, offset
#
# XXX XXX: need to extend this api -- bytes consumed, bytes remaining,
# fwd ptr, fragmentation information, etc

sub HSuck
{
#    whoami;
    my $self = shift;
    my %args = (
                @_);

#    greet %args;
    return undef
        unless (defined($args{value}));

    my $val = $args{value};
    my $off = (defined($args{offset})) ? 
        $args{offset} : scalar(@{$val}); # offsets are 1 based, not 0

    my $next     = $args{next};
    my $oldplace = $args{place};
    my $headless = $args{headless}; # set if not a true row head piece

    my $maxsize = 0;
    my $oldrowstat;

    if (defined($oldplace))
    {
#    my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$place] };
        my @rstats = $self->_exists2($oldplace);        

        return undef # no such row
            unless (scalar(@rstats) > 1);
        $oldrowstat = $rstats[0];
        $maxsize    = $rstats[2];
    }
    else
    {
        return undef
            unless $self->{can_insert};
    }

    unless ($maxsize)
    {
        # set maxsize as minimum of freespace or absolute freespace if
        # inserting a new row, or if the oldplace was a zero length
        # row
        $maxsize = ($self->{freespace} < $self->{absfree}) ?
            $self->{freespace} : $self->{absfree}; # min

        unless (defined($oldplace))
        {
            return undef # need space for the new row directory entry
                unless ($maxsize > $Genezzo::Block::RowDir::LenRowDirTemplate);
            $maxsize -= $Genezzo::Block::RowDir::LenRowDirTemplate;
        }
    }

    my ($packstr, $off2, $frag) = PackRow2($val, $maxsize, $off, $next);

    return undef
        unless (defined($packstr));

    my $rowstat = $DATAROW;

    # clear the tail flag if next is defined
    $rowstat &= ~($RowStats{tail})
        if (defined($next));

    # clear the head flag if not fully consumed
    $rowstat &= ~($RowStats{head})
        if ((defined($off2)) || defined($headless));

    my $place;

    if (defined($oldplace))
    {
        if ($rowstat != $oldrowstat)
        {
            # XXX XXX : use exists2 to get persistent update of rowstat
            my @rstats = $self->_exists2($oldplace, $rowstat);        

#            my $refrowdir = $self->{rowdir};
            # reset the rowstat if changed 
#            @{ $refrowdir->[$oldplace] }[0] = $rowstat;
        }
        $place = $oldplace;
        my $stat = ($self->_realstore($place, $packstr));

        return undef # XXX XXX: Super Bad!  We just trashed a valid row!!
            unless (defined($stat));
    }
    else
    {
        $place  = $self->_push_one($packstr, $rowstat);
    }
    return undef
        unless (defined($place));

    my @outi;

    push @outi, $place;
    if (defined($off2))
    {
        push @outi, $off2;
    }
    if (defined($frag))
    {
        push @outi, $frag; # column was fragmented
    }

    # place, [offset, [frag]]
    return @outi;

} # end HSuck

sub HPush # pushhash style
{
#    whoami;
    my ($self, $value) = @_;

    return undef
        unless $self->{can_insert};

    my $place = $self->_push_one($value, $DATAROW);
    return $place;
}

# array style push
sub PUSH # XXX XXX: need to check pushcount - may fail if run out of space...
{
#    whoami;
    my $self = shift;

    my $pushcount = 0;

    # push gets list of values...
    foreach my $value  (  @_) 
    {
        last
            unless $self->{can_insert};

        my $pstat = $self->_push_one($value, $DATAROW);
        last
            unless (defined($pstat));
        $pushcount++;
    }
    return $pushcount;
}

sub STORE # return undef if out of space
{
#    whoami ();

    my ($self, $place, $value) = @_;

    return (undef)
        unless ($self->EXISTS($place));

    return ($self->_realstore($place, $value));
}

# this function stores a value into a pre-existing slot in the block,
# resizing (by moving around other elements) if necessary.  
# No EXISTance check: can be used to store values when element was not a
# data row (e.g., if row was already deleted)
sub _realstore # return undef if out of space
{
#    whoami ();

    my ($self, $place, $value) = @_;

    my $refrowdir = $self->{rowdir};
    my $numelts   = $self->{numelts};

#  Carp::croak ("No such row")
    return (undef)
        unless ($place < $numelts);
    
    # note: rowstat is preserved, not set to datarow
    my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$place] };

    # XXX XXX XXX
    # NOTE : need to define undef specially
    # Undef is problematic because STORE returns undef on failure, and
    # the value when it suceeds.  But if you store an undef you cannot
    # distinguish success from failure.
    if (defined($value))
    {
        # clear nullness
        if (_isnull($rowstat))
        {
            #  bitclear...
            $rowstat &= ~($RowStats{isnull});
        }

    }
    else
    {
#        whisper "null!";
        # set nullness
        $value = "";
        $rowstat |= $RowStats{isnull};
    }

    my $packout = _row_write($value);
    my $packlen = length($packout);

    my $refbufstr = $self->{bigbuf};

#    whisper "old rowlen : $rowlen\npacklen : $packlen";

    my $sizediff = $rowlen - $packlen;

#    whisper "sizediff : $sizediff";

    # perfect match!!
    if (0 == $sizediff)
    {
        # add row to block
        substr($$refbufstr, $rowposn, $packlen) = $packout;

        return ($value);
    }

    my ($lastrowstat, $lastrowposn, $lastrowlen) = 
        @{ $refrowdir->[$numelts - 1] };

    if ($sizediff < 0) # new row is larger
    {

        # as updated row size increases, offset to last row decreases.
        # When the start of the last row overwrites the end of the
        # header we are in trouble...

        if (($lastrowposn 
             + $sizediff) <= _calctotalheader($numelts))
        {

            whisper "Ran out of space in block!! \n";

            return (undef);
        }

    }

    if ($place < ($numelts - 1))
    { # not the last row in the block, so have to move them around

#        whisper "shift the rows:";
        
        my $endchunk   = $rowposn;
        my $startchunk = $lastrowposn ;

#        whisper "endchunk : $endchunk\nlastrowposn : $lastrowposn";
#        whisper "lastrowlen : $lastrowlen";

        # startchunk (the position of the last row) is a smaller
        # offset than endchunk because we insert the rows at the end
        # of the block and work back toward the header
        #
        #     +------------+ <-- start of block
        #     | header     |
        #     +------------+
        #     |  .   free  |
        #     |  .   space |
        #     |  .         |
        #  -  +------------+ <-- startchunk = lastrowposn
        #  ^  | lastrow    |
        #  |  +------------+
        #  |  |  .         |
        #  s  |  .         |
        #  h  |  .         |
        #  i  |  .         |
        #  f  |  .         |
        #  t  |  .         |
        #  |  |  .         |
        #  |  +------------+ 
        #  v  | place+1    |
        #  -  +------------+ <-- endchunk = rowposn 
        #     | place      | <======= *update here*
        #     +------------+
        #     |  .         |
        #     |  .         |
        #     |  .         |
        #     +------------+
        #     | row 0      |
        #     +------------+ <-- end of block

        # XXX: would be nice to optimize this shift using something
        # like memmove

        my $bufchunk = substr($$refbufstr, $startchunk, 
                              $endchunk - $startchunk);

        substr($$refbufstr, $startchunk + $sizediff, $endchunk - $startchunk)
            = $bufchunk;
    }

    # add row to block
    substr($$refbufstr, $rowposn + $sizediff, $packlen) = $packout;

    # adjust freespace
    $self->{freespace} += $sizediff ;

    if ($self->{can_insert})
    {
        $self->{can_insert} = ($self->{freespace} > $self->{absfree});
        whisper "%free exceeded - inserts disabled"
            unless ($self->{can_insert});
    }
    else
    {
        $self->{can_insert} = ($self->{freespace} > $self->{absused});
        whisper "%used met - inserts re-enabled"
            if ($self->{can_insert});
    }

    # fix the rowlen for refrowdir[place] here - offsets are fixed in
    # loop below
    $rowlen = $packlen;

    # fix offsets for all rows
    for my $ii ($place..($numelts - 1))
    {
        # rowstat, rowposn, rowlen set for first pass already
        if ($ii == $place)
        {
            # reset the rowlen for the updated row
            @{ $refrowdir->[$ii] }[2] = $rowlen;
            # reset the rowstat if changed from null
            @{ $refrowdir->[$ii] }[0] = $rowstat;
        }
        else
        {
            ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$ii] };
        }

#        whisper "$ii: ",$rowposn + $sizediff;
        @{ $refrowdir->[$ii] }[1] = $rowposn + $sizediff;
#        $refrowdir->[$ii] = [$rowstat, $rowposn + $sizediff, $rowlen];

        SetRDEntry($self, $ii,  @{ $refrowdir->[$ii] } );
    }
    # update main header freespace
    SetStdHdr($self, $self->{blocktype}, $self->{numelts}, $self->{freespace})
        unless (0 == $sizediff);

    return ($value);

}

sub _packdeleted
{
#    whoami ();

    my $self = shift;

    return 0 
        if ($self->{compacted}); # no further cleanup possible

    my $refrowdir    = $self->{rowdir};
    my $oldfreespace = $self->{freespace};
    my $minsize      = length(_row_write(''));

    my $numrows = 0;

#    whoami $self->{numelts};

#    for (my $cnt = $self->{numelts} - 1; $cnt > 0; $cnt--)

    for (my $cnt = 0; $cnt < $self->{numelts}; $cnt++)
    {
        my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$cnt] };
        
#        whoami $cnt, $rowstat, $rowlen, $minsize;
        # count undeleted rows...
        if (_isdeletedrow($rowstat) && ($rowlen > $minsize))
        {
            $self->_realstore($cnt, '');
            $numrows++;
        }
        
    }

    $self->{compacted} = 1; # cleaned up as much as possible

    if ($numrows)
    {
        whisper "packed $numrows, saved ", 
        ($self->{freespace} - $oldfreespace), " bytes";
    }

    return $numrows;

}

# array style fetchsize
sub FETCHSIZE 
{
#    whoami ();

    my $self = shift;

    my $refrowdir = $self->{rowdir};
    
    my $numrows = 0;

    for (my $cnt = 0; $cnt < $self->{numelts}; $cnt++)
    {
        my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$cnt] };
        
        # count undeleted data rows...
        $numrows++
            if (_isheadrow($rowstat));
#            if (_isvaldatarow($rowstat)); XXX XXX: only head pieces
        
    }

    return $numrows;

}

# convert an array-like offset to a true hash key
sub _offset2hkey
{
#    whoami ();

    my ($self, $offset) = @_;

    my $refrowdir = $self->{rowdir};

    # Note: only positive offsets for now
    return undef
        unless ($offset > -1);
    return undef
        if ($offset > $self->{numelts});

    my $numrows = -1; # because first offset is zero

    for (my $cnt = 0; $cnt < $self->{numelts}; $cnt++)
    {
        my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$cnt] };

        # XXX XXX XXX XXX: how to handle this with row pieces?  should
        # this be only head rows?
        
        # count undeleted data rows...
        $numrows++
            if (_isvaldatarow($rowstat));

        return $cnt
            if ($numrows == $offset);
        
    }

    return undef;

}

sub _exists2   
{ 
    my ($self, $place, $newrowstat) = @_;

    # must be numeric for exists in array
    return undef
        unless (defined($place));
    return undef
        if ($place !~ /\d+/);

    my $refrowdir = $self->{rowdir};

    my $numelts =  $self->{numelts};

    my @outi;

    if ($place < $numelts)
    {
#    my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$place] };
        push @outi, @{ $refrowdir->[$place] };

        if (defined($newrowstat))
        {
            # update memory structs
            $refrowdir->[$place]->[0] = $newrowstat;
            $outi[0] = $newrowstat;
            # fix the rowdir entry in block header
            SetRDEntry($self, $place,  @{ $refrowdir->[$place] } );
        }
    }
    else
    {
#  Carp::croak ("No such row")
        push @outi, 0;
    }

    return @outi;
} # _exist2


sub EXISTS    
{ 
    my ($self, $place) = @_;

    # must be numeric for exists in array
    return undef
        unless (defined($place));
    return undef
        if ($place !~ /\d+/);

    my $refrowdir = $self->{rowdir};

    my $numelts =  $self->{numelts};

#  Carp::croak ("No such row")
    return (0)
        unless ($place < $numelts);

    my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$place] };

    # XXX XXX XXX XXX: how to handle this with row pieces?  should
    # this be only head rows?

    return (_isvaldatarow($rowstat));

}

sub DELETE    
{
#    whoami (); 
    my ($self, $place) = @_;

    return (undef)
        unless ($self->EXISTS($place));

    my $refrowdir = $self->{rowdir};
    my $numelts   = $self->{numelts};

    my ($rowstat, $rowposn, $rowlen) = @{ $refrowdir->[$place] };

    # normal case if not at end
    unless (($place + 1) == $numelts)
    {
        $self->{compacted} = 0; # not compacted - we now have a hole

        # clear nullness for deleted rows
        $rowstat &= ~($RowStats{isnull})
            if (_isnull($rowstat));

        # mark row as deleted
        @{$refrowdir->[$place]} = (($rowstat | $RowStats{deleted}),
                                   $rowposn, $rowlen );
        
        # fix the rowdir entry in block header
        SetRDEntry($self, $place,  @{ $refrowdir->[$place] } );
        # don't need to update main hdr - number of rowdir elements
        # and free space unchanged until we can really free up this
        # row or shuffle the space...

        return ($self->_realfetch ($rowposn, $rowlen ));
    }

    # NOTE: trivial truncation if at end of row directory

    my $clrblock = 0;
    my ($istat, $iposn, $iln); # status, position, length
    
    $iln = $rowlen; # first pass use rowlen from specified row to
                    # fix freespace

  L_SCRUB:
    while (1)
    {
        $self->{numelts}   -= 1;
        $self->{freespace} += ($iln + $Genezzo::Block::RowDir::LenRowDirTemplate);
        # clear the block if rownum = 0
        $clrblock = ($self->{numelts} == 0);
            
#            whisper "delete $place";
        delete ($refrowdir->[$place]);
        
        # break if rownum = 0
        last L_SCRUB if ($clrblock);
        
        $place--;
        ($istat, $iposn, $iln) = @{ $refrowdir->[$place] };
        
        # if penultimate row was already deleted let's be a good
        # citizen and scrub him as well

        last L_SCRUB unless (_isdeletedrow($istat));
    } # end while scrub

    my $refbufstr = $self->{bigbuf};

    # add new row count to main header
    if ($clrblock)
    {
        ClearStdBlock($self);
    }
    else
    {
        SetStdHdr($self, 
                  $self->{blocktype}, $self->{numelts}, 
                  $self->{freespace});
    }

    unless ($self->{can_insert})
    {
        $self->{can_insert} = ($self->{freespace} > $self->{absused});
        whisper "%used met - inserts re-enabled"
            if ($self->{can_insert});
    }
 
    # don't need to update rowdir elements in header -- numelts
    # specifies the length of the rowdir, and the trailing elemnts
    # will just get overwritten if new rows are added
    
    # return the deleted value
    return ($self->_realfetch ($rowposn, $rowlen ));
} # end DELETE

sub CLEAR
{
#    whoami (); 
    my $self = shift;

    my $refbufstr = $self->{bigbuf};

    # clear the main header
    ClearStdBlock($self);
    $self->_init(refbufstr => $refbufstr, blocksize => $self->{blocksize});

#    greet $self;
}

# reverse iterator...
sub _lastkey {
    return $_[0]->_prevkey($_[0]->{numelts} + 1);
}
sub _prevkey {
    my ($self, $nextkey) = @_;
    my $kk = $nextkey - 1;

    while ($kk > 0)
    {
        my @rstats = $_[0]->_exists2($kk);

        return $kk
            if ((scalar(@rstats) > 1) && _isheadrow($rstats[0]));
        $kk--;
    }
    return (undef);
}

sub NEXTKEY  { 

    my ($self, $prevkey) = @_;
    my $kk = $prevkey + 1;

    while ($kk < $self->{numelts})
    {
        my @rstats = $_[0]->_exists2($kk);

        return $kk
            if ((scalar(@rstats) > 1) && _isheadrow($rstats[0]));
        $kk++;
    }
    return (undef);
}

sub FIRSTKEY { 
    return $_[0]->NEXTKEY(-1);
}


END {

}


1;

__END__
# Below is stub documentation for your module. You better edit it!

=head1 NAME

Genezzo::Block::RDBlock.pm - Row Directory Block tied hash class.  A
class that lets you treat the contents of a block (byte buffer) as a
hash.

Note: This implementation is almost, but not quite, a pushhash.  The
push hash implementation is B<Genezzo::Row::RSBlock>.  It also forms the
basis of a tied array in B<Genezzo::Block::RDBArray>.


=head1 SYNOPSIS

 use Genezzo::Block::RDBlock;
 use Genezzo::Block::Std;

 local $Genezzo::Block::Std::DEFBLOCKSIZE = 500;

 my $buff = "\0" x 500; # construct an empty byte buffer

 my %tied_hash = ();

 my $tie_val = 
     tie %tied_hash, 'Genezzo::Block::RDBlock', (refbufstr => \$buff);

 # pushhash style 
 # (note that the "PUSH" pseudo key is not supported)...
 my $newkey = $tie_val->HPush("this is a test");

 # or array style, your choice
 my $pushcount = $tie_val->PUSH(qw(push lots of data));

 $tied_hash{$newkey} = "update this entry";

 # a hash that supports array style FETCHSIZE
 my $getcount = $tie_val->FETCHSIZE(); # Note: not HCount

=head1 DESCRIPTION

RDBlock is the basis for persistent tied hashes, pushhashes, and tied
arrays.  After the hash is tied to the byte buffer, the buffer can be
written to persistent storage.  The storage is designed such that
inserts/appends/pushes are fairly efficient, and deletes are
inexpensive.  The pctfree/pctused parameters allow some tuning to
reserve space in the buffer for updates that "grow" existing values.
Updates that do not change the packed size of data are about as
efficient as insert/appends -- just the cost to copy your bytes into
the buffer -- but updates that do change the size of stored values can
require a large amount of byte shifting to open up storage space.
Also, the buffer does not grow to accomodate large values.  Wrapper
classes are necessary to specify mechanisms for packing complex data
structures and techniques to split objects across multiple buffers.

=head1 ARGUMENTS

=over 4

=item refbufstr
(Required) - a reference to the byte buffer used for storage.

=item blocksize
(Optional) - the size of the supplied byte buffer.
Default is $Genezzo::Block::Std::DEFBLOCKSIZE.
                    
=item pctfree
(Optional) - the percentage of space kept free for future updates.
Default is 30 (percent).
                    
=item pctused
(Optional) - after the block is full, the percentage of space that must
be open before inserts are re-enabled.  Default is 50 (percent).

=back


=head1 CONCEPTS

The structure and techniques for the Row Directory Block are described
in Chapter 14, "The Tuple-Oriented File System", of "Transaction
Processing: Concepts and Techniques" by Jim Gray and Andreas Reuter,
1993.

A tuple is a collection of values -- in the standard vernacular you
would call it a "row" in a database.  The I<refbufstr> argument to the
hash constructor is a "block", a fixed-size contiguous buffer of
bytes.  When you write (C<STORE>) a value into the RDBlock hash, it
writes an entry into the block as a byte string, and reads (C<FETCH>)
work in an analogous fashion.  

The RDBlock data structures refer to stored values as "rows", but the
basic C<STORE> and C<FETCH> only understand how to store and retrieve
individual byte strings.  Wrapper classes for RDBlock must
marshall/unmarshall (Freeze/Thaw) between simple strings and more
complex data structures.

The block has some header and footer information, plus a I<row
directory>, a data structure that records the offsets, extents, and
status information of the stored row data.  While the physical
location of row data in a block may change as other rows are added,
deleted or modified, the row keeps the same hash key.

Each row has an associated "status" bitfield, which is some
combination of the following values:

=over 4

=item  deleted

set if row is deleted.  Deleted rows are simply marked as deleted, but
the physical storaged is not immediately recouped.  

=item  data 

set for data rows, unset for metadata.  All information stored via the
standard public interfaces is data.  You can manipulate the private
interfaces to store "metadata", additional rows that describe, for
example, block contents, transaction information, or data
relationships, but are invisible to the public interfaces.  By
convention, row 0 is always a metadata row.  

=item  lock

set if row is locked.  Not used in this base class -- provided for
subclasses that must supply and maintain the appropriate metadata to
identify locker and transaction information.

=item  head

set if the stored value is the very first part of a row.

=item  tail

set if the stored value is the very last part of a row.  If C<STORE>
writes a complete value it sets both head and tail to true.  The base
class only writes rows that fit in a single block, so both head and
tail are always set.

These flags are useful if you wish to write subclasses with rows
that span multiple blocks.  Neither head nor tail is set if only the
middle section of a multi-part row is stored.

=item  isnull

If you supply C<STORE> with a value of undef, it writes a marker for a
zero-length string and sets this flag.  C<FETCH> will correctly return
an undef.  

Note: When packing more complex data structures, make sure to use an
encoding that distinguishes between undefs and zero-length strings.  A
simple scheme for packing an array of strings is to prefix the packed
array with a bitstring that specifies which entries are null.

=back


=head1 FUNCTIONS

RDBlock support all standard hash operations, with the exception
that you cannot create or insert a user key -- you must push new
entries and use the generated key or basic iteration to retrieve your
data.  

It also supports three additional public methods: an array style
C<PUSH> and C<FETCHSIZE>, plus a PushHash style HPush.  Note that
these methods are associated with the tie value (i.e. the blessed ref
for the RDBlock class), not the tied hash.  Finally, it has five
"private" methods that may be of use in constructing subclasses:
push_one, packdeleted, offset2hkey, lastkey, prevkey

=over 4

=item PUSH this, LIST

PUSH appends the list to the end of the hash and returns the number of
items it pushed.

=item FETCHSIZE

Returns the total number of valid, undeleted data items in the hash.

=item HPush

HPush returns the new key for each pushed value.  It only accepts a
single argument, not a list.

my $newkey = $tie_val->HPush("this is a test");

Note that there is not a corresponding "pop" operation.

=back

=head2 EXPORT

DATAROW, RowStat

=head1 LIMITATIONS

The storage mechanism uses network longs (32 bits?) to describe the
lengths of rows and offsets within the block.  (That seems pretty
large -- maybe it should use shorts to restrict blocksize and row
piece length to 64K?  Or init should take an optional module name for
block type that lets us vary the row directory, header and footer
sizing).

=head1 TODO

=over 4

=item use row directory rowlen vs len/value for row storage

=item meta row - should binary search for meta id

=item unicode support

=back

=head1 AUTHOR

Jeffrey I. Cohen, jcohen@genezzo.com

=head1 SEE ALSO

L<perl(1)>.

Copyright (c) 2003, 2004 Jeffrey I Cohen.  All rights reserved.

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

Address bug reports and comments to: jcohen@genezzo.com

For more information, please visit the Genezzo homepage 
at L<http://www.genezzo.com>

=cut
