#!/usr/bin/perl
#
# $Header: /Users/claude/fuzz/lib/Genezzo/RCS/Util.pm,v 7.8 2005/12/12 09:13:13 claude Exp claude $
#
# copyright (c) 2003,2004,2005 Jeffrey I Cohen, all rights reserved, worldwide
#
#
package Genezzo::Util;  # assumes Some/Module.pm

use strict;
use warnings;

use Carp;
use Data::Dumper ;

BEGIN {
    use Exporter   ();
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

    # set the version for version checking
#    $VERSION     = 1.00;
    # if using RCS/CVS, this may be preferred
    $VERSION = do { my @r = (q$Revision: 7.8 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

    @ISA         = qw(Exporter);
    @EXPORT      = qw(&whisper &whoami &greet 
                      &Validate &FlatSave &FlatLoad 
                      &HumanNum &NumVal &checkKeyVal
                      &PackRowCheck &PackRow &UnPackRow &PackRow2
                      &getUseRaw &setUseRaw &gzn_read &gnz_write);
    %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],

    # your exported package globals go here,
    # as well as any optionally exported functions
#    @EXPORT_OK   = qw($Var1 %Hashit &func3 &func5);
    @EXPORT_OK   = qw($QUIETWHISPER $WHISPERDEPTH $DEFBLOCKSIZE $USECARP 
                      $DEFDBSIZE $MINBLOCKSIZE $MAXBLOCKSIZE $MAXDBSIZE
                      $UNPACK_TEMPL_ARR $WHISPER_PRINT $UTIL_EPRINT 
                      $WHISPERPREFIX $RAW_IO);

}

our @EXPORT_OK;

our $UNPACK_TEMPL_ARR;

our $PACK_NUMCOL    = 'w';    # pack the number of columns in a row
our $UnPACKVAL_TYPE = 'w/a';  # unpack a column value
our $PACKVAL_STR    = $UnPACKVAL_TYPE . '*'; # add the wildcard to consume
                                             # remaining values...
sub _numcol_len
{
    my $numcols = $_[0];

    # XXX XXX: no speed up for this optimization ?

    if (($PACK_NUMCOL eq 'w')) # BER ints
    {
        # just lookup byte length in table
#        return 0 if ($numcols < 1);    # ??
        return 1 if ($numcols < 128);    # 2**(7*1)
        return 2 if ($numcols < 16384);  # 2**(7*2)

        # tops out at 147 bytes for 2**1022 (about 4.5e307)

        # [Frank Tipler] According to the Bekenstein Bound we need
        # about 10^45 bytes per human simulation, and 10^123 for the
        # visible universe.  All possible variants of the known
        # universe requires 10^(10^123) bytes, so need to update
        # pack_numcol and unpackval_type after the singularity.

    }

    # else calculate length...
    return length(pack($PACK_NUMCOL, $numcols)); # byte length of 
                                                 # the column count
}

sub PackBits
{
    my $numcols = shift;
    return (8 * (($numcols < 7) ? 1 : (int(($numcols+1)/8) + 1)));
}

BEGIN {

    # Build an array of common unpack templates, versus constructing
    # the templates dynamically in UnPackRow

    $UNPACK_TEMPL_ARR = [];
    $PACK_NUMCOL    = 'w';    # pack the number of columns in a row
    $UnPACKVAL_TYPE = 'w/a';  # unpack a column value
    $PACKVAL_STR    = $UnPACKVAL_TYPE . '*'; # add the wildcard to consume
                                             # remaining values...

    for my $numcols (1..100)
    {
        my $templ;

        my $skippy = _numcol_len($numcols); # byte length of the column count

        $templ     = "x$skippy "; # unpack template to skip column count bytes

        my $nullvec_len = PackBits($numcols) / 8; # byte length of null vector

        # build string to unpack each column
        $templ  .= "a$nullvec_len ";               # unpack the null bitvec
        $templ  .= "$UnPACKVAL_TYPE " x $numcols;  # unpack other cols

        $UNPACK_TEMPL_ARR->[$numcols] = $templ;
    }

}

our $USE_FSYNC;

BEGIN {
    use Config;

    # Win32: handle missing fsync problem
    if (exists($Config{d_fsync})
        && ($Config{d_fsync} eq "define"))
    {
#        print "\nuse fsync\n";
        $USE_FSYNC = 1;
    }
    else
    {
        $USE_FSYNC = 0;
    }

}

# non-exported package globals go here


# initialize package globals, first exported ones
#my $Var1   = '';
#my %Hashit = ();

our $QUIETWHISPER = 0; # XXX XXX XXX XXX
our $WHISPERDEPTH = 1;
our $WHISPERPREFIX = "whisper: ";

our $RAW_IO          = 0;   # use "cooked" file systems by default
our $ALIGN_BLOCKSIZE = 4096; # header alignment for raw io

our $DEFBLOCKSIZE = 4096;
our $DEFDBSIZE    = 80 * $DEFBLOCKSIZE ; # 327680 was 163840

our $MINBLOCKSIZE = 1024; # 512;

our $MAXBLOCKSIZE = 65536;
our $MAXDBSIZE    = 2**31; # 2 Gig # XXX : 4 gig ok all platforms?

our $USECARP = 1;

our $WHISPER_PRINT   = sub { print @_ ; };
our $UTIL_EPRINT = sub { print @_ ; };

# then the others (which are still accessible as $Some::Module::stuff)
#$stuff  = '';
#@more   = ();

# all file-scoped lexicals must be created before
# the functions below that use them.

# file-private lexicals go here
#my $priv_var    = '';
#my %secret_hash = ();
# here's a file-private function as a closure,
# callable as &$priv_func;  it cannot be prototyped.
#my $priv_func = sub {
    # stuff goes here.
#};

# make all your functions, whether exported or not;
# remember to put something interesting in the {} stubs

sub whowasi { (caller(1))[3] . '()' }

# use the magic goto
sub whisper { goto &_realwhisper unless $QUIETWHISPER }
sub _realwhisper 
{ 
    my $outmess = shift @_;

    return unless (defined($outmess));

    my $wprefix = $WHISPERPREFIX;

    # print all the args space delimited

    if (scalar(@_))
    {
        $outmess .= ' ';
        if (scalar(@_) > 1)
        {
            $outmess .= join(' ',@_);
        }
        else
        {
            $outmess .= $_[0];
        }

    }
    # add a newline if necessary
    $outmess .= "\n" unless $outmess=~/\n$/;

    # treat string as multiple lines, and prefix each with "whisper:" prefix
    $outmess =~ s/^/$wprefix/gm 
        if (defined($wprefix));

    # taken from carp::heavy
    if (1)
    {
        # print high-end chars as 'M-<char>'
        $outmess =~ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
        # print remaining control chars as ^<char>
        $outmess =~ s/([\0-\11])/sprintf("^%c",ord($1)^64)/eg;
        # ignore newline (^J = octal 12)
        $outmess =~ s/([\13-\37\177])/sprintf("^%c",ord($1)^64)/eg;
    }
    # treat string as multiple lines, and prefix each with "whisper:" prefix
#    $outmess =~ s/\^J/\n$wprefix/gm ;

    &$WHISPER_PRINT( $outmess );
}

sub whoami  
{ 
    return if $QUIETWHISPER;

    my $maxdepth = $WHISPERDEPTH;

    foreach my $calldepth (1..$maxdepth)
    {
        my $outi = (caller($calldepth))[3]  || 'MAIN?';  
        $outi .= '()';

        if (1 == $calldepth)
        {
            whisper $outi, @_; 
        }
        else
        {
            whisper ' ' x ($calldepth - 1), $outi; 
        }
    }
}
sub greet   
{ 
    return if $QUIETWHISPER;

    my $maxdepth = $WHISPERDEPTH;

    foreach my $calldepth (1..$maxdepth)
    {
        my $outi = (caller($calldepth))[3]  || 'MAIN?';  
        $outi .= '()';

        if (1 == $calldepth)
        {
            whisper $outi, " : \n", Dumper(@_); 
        }
        else
        {
            whisper ' ' x ($calldepth - 1), $outi; 
        }
    }
}

sub Validate 
{
#    greet @_;

    my ($package, $filename, $line) = caller(1);

    my @param = @_;

    my %args = %{$param[0]};

    my %required = %{$param[1]};

#    print Dumper(%args);
#    print Dumper(%required);

    while (my ($kk, $vv) = each (%required))
    {
#        print "$kk => ", Dumper($vv);
        unless (exists ($args{$kk}))
        {
            # add a newline if necessary
            $vv .= "\n" unless $vv=~/\n$/;

            if ($USECARP)
            {
                carp $vv;
            }
            else
            {
                my $m1 = "$package $filename $line: " . $vv;
                &$UTIL_EPRINT( $m1 );
            }
            return 0;
        }
    }

    return 1;
};

sub _notnum
{
    unless (scalar(@_))
    {
        whisper "no value supplied!";
        return 0;
    }
    unless (defined($_[0]))
    {
        whisper "undef value supplied!";
        return 0;
    }


    # natural? numbers (non-negative integers)
    return ($_[0] !~ /\d+/);
}
sub _notnummsg
{
    return "no values supplied!"
        unless (2 == scalar(@_));
    
    my ($nname, $val) = @_;
    return undef
        unless _notnum($val);
    
#Argument "sdf" isn't numeric in array element at ./t2.pl line 61.
    my $emsg = 
        "Non-numeric value (" . $val . ") for " . $nname; 

    return $emsg;
}

# convert human numbers (e.g. 2G) to pure numbers
# Note: now supports decimal point in specification, e.g. 1.4K or 0.5G
sub HumanNum
{
    my ($package, $filename, $line) = caller(1);

    my %required = (
                    val  => "no value supplied",
                    name => "no name supplied"
                    );

    my %args = (
                verbose => 1,
                units  => "bytes",
                @_);

    return undef
        unless (Validate(\%args, \%required));

    my $numregexp = '^-?(?:\d+(?:\.\d*)?|\.\d+)$';

    my $emsg = ();
    my $val = $args{val};
    my $nam = $args{name};
    my $outi;

# courtesy of /usr/share/units.dat (see units -V)
#yotta-                  1e24     # Greek or Latin octo, "eight"
#zetta-                  1e21     # Latin septem, "seven"
#exa-                    1e18     # Greek hex, "six"
#peta-                   1e15     # Greek pente, "five"
#tera-                   1e12     # Greek teras, "monster"
#giga-                   1e9      # Greek gigas, "giant"
#mega-                   1e6      # Greek megas, "large"
#kilo-                   1e3      # Greek chilioi, "thousand"

# k = 1024, M = k * k = k^2, G = k * M = k^3, T = k * G=k^4, 

# NOTE: computer usage doesn't match SI prefixes...
    my %unitsprefix = (
                       Y => [ 80, "Yotta"],
                       Z => [ 70, "Zetta"],
                       E => [ 60, "Exa" ],
                       P => [ 50, "Peta"],
# XXX: 2^49 is about as high as we go...
                       T => [ 40, "Tera"],
                       G => [ 30, "Giga"],
                       M => [ 20, "Mega"],
                       K => [ 10, "Kilo"]
                       );

    return $val
        if ($val =~ m/$numregexp/);

    if ($val =~ m/^\d+(\.\d*)?[pezy]$/i)
    {
        my @ggg = ($val =~ m/(\d+(\.\d*)?)([kmgtpezy])/i);

        my $ll = scalar(@ggg) - 1;

        $emsg = "$nam ($val) too large - ";

        #        Peta                              bytes 
        $emsg .= $unitsprefix{uc($ggg[$ll])}->[1] . $args{units};

        #          (2^50) > 2^49
        $emsg .= " (2^" . $unitsprefix{uc($ggg[$ll])}->[0];
        $emsg .= ") not supported";
    }
    else
    {
        if ($val =~ m/^\d+(\.\d*)?[kmgtpezy]$/i)
        {
            my @ggg = ($val =~ m/(\d+(\.\d*)?)([kmgtpezy])/i);
            
#            greet @ggg;

            $outi = $ggg[0];
            if (scalar(@ggg) > 2)
            {
#                $outi .= "." . $ggg[1];
                shift @ggg;
            }

            $outi *= (2**($unitsprefix{uc($ggg[1])}->[0]))
                if (scalar(@ggg) > 1);

        }
        else
        {
            $emsg = "illegal numeric format ($val) for $nam";

        }
    }
    return $outi unless (defined($emsg));

    return 0 unless ($args{verbose});

    if ($USECARP)
    {
        carp $emsg;
    }
    else
    {
        my $m1 = "$package $filename $line: " . $emsg;
        &$UTIL_EPRINT( $m1 );
    }
    return undef;
}

sub NumVal 
{
#    greet @_;

    my ($package, $filename, $line) = caller(1);

    my %required = (
                    val  => "no value supplied",
                    name => "no name supplied"
                    );

    my %args = (
                verbose => 1,
                @_);

    return 0
        unless (Validate(\%args, \%required));

    my $emsg = ();

    my $optional_args = {
        MIN => {
            typ  => "_MINIMUM_",
            msg  => " less than minimum ",
            # 0 is supplied value, 1 is specified minimum
            comp => sub { return $_[0] < $_[1] ; }
        }, # end min
        MAX => {
            typ  => "_MAXIMUM_",
            msg  => " exceeds maximum ",
            # 0 is supplied value, 1 is specified maximum
            comp => sub { return $_[0] > $_[1] ; }
        } # end max
    };


  L_mmm:
    {
        $emsg = _notnummsg($args{name}, $args{val});
        last L_mmm if (defined($emsg));

        foreach my $vv (keys (%{$optional_args}))
        { # big for
            if (exists($args{$vv}))
            { # exists check
                my $tval  = $args{$vv};
                # e.g. tname = _MINIMUM_
                my $tname = $optional_args->{$vv}->{typ};
                $tname .= " " . $args{name}; 
                my $tmsg = _notnummsg($tname, $tval);
                if (defined($tmsg))
                { # is bound a number
                    if (defined($emsg))
                    {
                        $emsg .= "\n" ;
                        $emsg .= $tmsg;
                    }
                    else
                    {
                        $emsg = $tmsg;
                    }
                }
                else
                { # bound is a legit number

                    my $newsub = $optional_args->{$vv}->{comp};

                    if (&$newsub($args{val}, $args{$vv}))
                    { # within bounds?
                        if (defined($emsg))
                        {
                            $emsg .= "\n" ;
                            $emsg .= 
                                "Numeric value (" . $args{val} ;
                        }
                        else
                        {
                            $emsg = 
                                "Numeric value (" . $args{val} ;
                        }
                        $emsg .= 
                            ") for " . $args{name}; 
                        # e.g. " execeeds maximum "
                        $emsg .= 
                            $optional_args->{$vv}->{msg} . 
                                "(". $args{$vv} . ")";

                    }
                } # end bound is a legit number
            } # end exists check
        } # end big for
    }

    return 1 unless (defined($emsg));

    return 0 unless ($args{verbose});

    if ($USECARP)
    {
        carp $emsg;
    }
    else
    {
        my $m1 = "$package $filename $line: " . $emsg;
        &$UTIL_EPRINT( $m1 );
    }
    return 0;
}


sub FlatSave 
{
#    whoami;

    my ($cpackage, $cfilename, $cline) = caller;

    my %optional = (
                    type => $cpackage,
                    implementation => $cfilename
                    );

    my %required = (
                    outfile => "no output file supplied! \n" ,
                    inhash => "no input hash supplied! \n",
                    );

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

#    print Dumper(%args);

    return 0
        unless (Validate(\%args, \%required));

    my %hashreq = (
                   name => "no name supplied! \n",
                   package_version => "no package_version supplied! \n",
                   rcs_header => "no rcs_header supplied! \n",
                   rcs_revision => "no rcs_revision supplied! \n",
                   );

    my $inhash = $args{inhash};

#    greet $inhash;

    return 0
        unless (Validate($inhash, \%hashreq));

    {
        my $outfile = $args{outfile};

        open (DICOUT, "> $outfile ") 
            or die "Could not tee open $outfile for writing : $! \n";

        $inhash->{type} = $args{type};
        $inhash->{implementation} = $args{implementation};

        my $bighash = \$inhash;
        {
            $| = 1; # force flush
            print DICOUT  Data::Dumper->Dump([$bighash], [qw(*bighash )]); 
            $| = 1;
            close (DICOUT);
        }
    }

    return (1);


} # end dictsave

sub FlatLoad
{
#    whoami;

    my %optional = (
                    );

    my %required = (
                    infile => "no input file supplied! \n" ,
                    outhash => "no output hash supplied! \n",
                    );

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

#    print Dumper(%args);

    return 0
        unless (Validate(\%args, \%required));

    my $inifile = $args{infile};

    open (INIFILE, "< $inifile" ) 
        or die "Could not open $inifile for reading : $! \n";

    # $$$ $$$ undefine input record separator (\n")
    # and slurp entire file into variable
    local $/;
    undef $/;

    my $whole_file = <INIFILE>;
    close (INIFILE);

#        print $whole_file;
        
    my $bighash = ();

    {
        eval "$whole_file";
    }

    my $outhash = $args{outhash};
    while (my ($kk, $vv) = each (%{${$bighash}}))
    {
#            print "$kk => ", Dumper($vv);
        $outhash->{$kk} = $vv;
    }

    print "Name : ", $outhash->{name}, "\n";
    print "Type : ", $outhash->{type}, "\n";
    print "Package Version : ",  $outhash->{package_version}, "\n\n";

    print "RCS Header : \n\t", $outhash->{rcs_header}, "\n\n";

    return (1);
}

sub checkKeyVal
{
#    greet @_;
    my ($package, $filename, $line) = caller(1);

    my %required = (
                    kvpair    => "no value supplied",
                    validlist => "no valid list supplied"
                    );

    my %args = (
                verbose => 1,
                @_);

    return undef
        unless (Validate(\%args, \%required));

    my $kvpair     = $args{kvpair};
    my $validlist  = $args{validlist};

    my $emsg;
    my @subop  = (split('=', $kvpair));

    if (2 == scalar(@subop))
    {
        if (defined($validlist))
        {
            my $pat = join ('|' , @{$validlist});

            unless ($subop[0] =~ /$pat/o)
            {
                $emsg = "key (" . $subop[0] . ") not in list (" . $pat . ")";
            }
        }
        else
        {
                $emsg = "list of valid keys not supplied";
        }
    }
    else
    {
        $emsg = "could not split " . $kvpair;
    }

    return \@subop unless (defined($emsg));

    return undef unless ($args{verbose});

    if ($USECARP)
    {
        carp $emsg;
    }
    else
    {
        my $m1 = "$package $filename $line: " . $emsg;
        &$UTIL_EPRINT( $m1 );
    }
    return undef;
}


# Basic row packing format is a column count followed by a list of
# length/value pairs:
#
# number of cols [ +1] , (column length/column value)...
#
# An extra first column, a bitvec, is added to deal with nulls.
#
sub PackRowCheck
{
    my ($value, $maxsize) = @_;

    my $numcols = scalar (@{$value});

#    my $numbits = 8 * (($numcols < 8) ? 1 : (int($numcols/8) + 1));
    my $numbits = PackBits($numcols);

    my $nullstr = pack("B*", "0"x$numbits);

    my $packstr;
    my $headstr = pack($PACK_NUMCOL, $numcols);

    if (defined($maxsize))
    {
        $maxsize -= length($nullstr);
        $maxsize -= length($headstr);
    }

    if ($numcols)
    {
        my $colcnt = 0;

        foreach my $elt (@{$value})
        {
            if (defined($elt))
            {
                if (defined($maxsize))
                {
                    my $len = length($elt);
                    return undef       # too small
                        if ($len > $maxsize);
                    $maxsize -= $len;
                }
                $packstr .= pack($PACKVAL_STR, $elt);
            }
            else
            {
                vec($nullstr, $colcnt+1, 1) = 1;
                $packstr .= pack($PACKVAL_STR, "");
            }
            $colcnt++;
        }
    }
#    print unpack("b*", $nullstr), "\n";
#    $headstr .= pack($PACKVAL_STR, $nullstr);
    $headstr .= $nullstr;
    $headstr .= $packstr
        if (defined($packstr));
    return $headstr;

} # end PackRowCheck
sub PackRow
{
    my $value = shift;

    my $numcols = scalar (@{$value});

#    my $numbits = 8 * (($numcols < 8) ? 1 : (int($numcols/8) + 1));
    my $numbits = PackBits($numcols);

    my $nullstr = pack("B*", "0"x$numbits);

    my $packstr;
    my $headstr = pack($PACK_NUMCOL, $numcols);
    
    if ($numcols)
    {
        my $colcnt = 0;

        foreach my $elt (@{$value})
        {
            if (defined($elt))
            {
                $packstr .= pack($PACKVAL_STR, $elt);
            }
            else
            {
                vec($nullstr, $colcnt+1, 1) = 1;
                $packstr .= pack($PACKVAL_STR, "");
            }
            $colcnt++;
        }
    }
#    print unpack("b*", $nullstr), "\n";
#    $headstr .= pack($PACKVAL_STR, $nullstr);
    $headstr .= $nullstr;
    $headstr .= $packstr
        if (defined($packstr));
    return $headstr;

} # end PackRow

=head1 PackRow2

PackRow2 takes list of items and packs them (non-destructively) into a
string of <= maxsize bytes.  If offset is not specified, it builds the
string starting with the last item in the list, prepending it with
each preceding item until it runs out of space or the list is fully
consumed.  If the packer runs out of space, it returns the offset into
the list where it stopped.  The offset may be supplied as an argument
to this function, and the packer will pack the remainder of the list
starting at the offset, working back to the beginning of the list.
The final argument to the packer is a "next pointer", a string that
identifies the location of the next part of a row split into multiple
pieces.  Since the packer processes a list from back to front, the
address of the "next" piece can be obtained before constructing the
preceding piece.  If the packer can process a complete list, it
returns an array containing a single packed string, a byte string
consisting of a count of the number of packed items, followed by
length/value pairs for each item.  If the packer runs out of space, it
returns an array of the packed string and the offset of the remaining
items

For example, given the list @a = qw(alpha bravo charlie delta), and a
maxsize=15, PackRow2 returns a packed string (something like
x01x05delta) and the offset 3, indicating that the last item in the
list was processed, and the packer ran out of space at the third item.
The packed string could be stored in a pushhash, which would return an
index, e.g. "5/2", suitable for a next pointer.  Packing the remainder
of the string generates another packed string
(e.g. x02x07charliex035/2) and the offset 2.  The packing and storage
process continues until the entire list is consumed.

=head2 advanced topics

=over 4

=item null vector

The packed string always contains a bitstring to identify null
columns, which is used by UnPackRow to correctly distinguish between
nulls and zero length strings.

=item next pointer

Since the next pointer is used to find the next part of a split row,
it must always remain whole -- if it was split, how could you find the
next piece?  The next pointer is a convention supported by
PackRow/UnPackRow to facilitate the construction of methods that
manipulate split rows.  The packing function only flattens an array
into a byte string or series of strings; it does not provide any
intrinsic support to traverse these strings.  Functions that
manipulate packed rows may use additional structures to support
multi-part rows, such as external metadata in the block row directory,
or specialized metadata columns embedded in the row itself.


=item column splitting (fragmentation)

The packer can support rows with individual columns that exceed the
maxsize.  The offset can simultaneously maintain the current column
position, as well as the current character offset in that column.
It's wicked complicated.  Generally, we say that a row is split into
row pieces, and the row pieces are chained (via the next pointers),
which lets us reconstruct a complete row.  Individual columns that are
split are said to be fragmented.

=head2 future work

The packer could be extended to support more complex structures than
arrays of scalars.  In lieu of this ability, these structures can be
flattened using Data::Dumper or YAML to large strings.

=back


=cut

#
# val, maxsize,
# offset, next
#
sub PackRow2
{
    use POSIX ; #  need some rounding
#    whoami;
    my ($value, $maxsize, $offset, $next) = @_ ;
#    greet @_;
    my @outi;

    # Note: maxsize must be an integer -- round down
    $maxsize = POSIX::floor($maxsize); 


    # Need to support an offset that allows a split column, not just a
    # split row.

    # Column Offset / Substr Offset
    my ($coloff, $suboff) = split('/', $offset);
    my @subargs;
    if (defined($suboff))
    {
        # substr (col, 0, $suboff)
        push @subargs, 0;
        push @subargs, $suboff;
    }

    # Note: if offset indicates that column was split then mark
    # next ptr

    my $gotnext = (defined($next)); # have a next ptr at end...

    # the next ptr is always the last column in a packed row, which
    # means it is the first column packed.  It *must* fit without
    # fragmentation.

    my $numcols = scalar (@{$value});
    if (defined($coloff))
    {
        if ($coloff > $numcols)
        {
            whisper "offset $coloff greater than $numcols";
            return undef;
        }
        $numcols = $coloff;
    }

    # XXX: should fix this to allow negative offsets, like standard
    # arrays.  Just scalar(val) + $numcols if numcols < 0 ? Need to
    # fix offset to be zero based, not one based, in that case
    $numcols++
        if ($gotnext); # add one for next ptr, which is last col...

#    my $numbits = 8 * (($numcols < 8) ? 1 : (int($numcols/8) + 1));
    my $numbits = PackBits($numcols);
    my $nullstr = pack("B*", "0"x$numbits); # bitvec of null columns

    my ($packstr, $prevpack, $max2);
    my $headstr = pack($PACK_NUMCOL, $numcols);

    my $colcnt = 0;
    
    if (defined($maxsize))
    {
        if (0) # ($maxsize < 30) # don't fragment too small...
        {
            return undef;
        }

        $max2  = $maxsize; # adjust max2 to reflect space left
#        greet $max2;

        # size of column count is constant (len headstr)
        # size of nullstr at least 1 byte...
        $max2 -= length($headstr) + length(pack($PACKVAL_STR, $nullstr)); 
#        greet $max2;

    }

    if ($numcols)
    {
        my $cnt8 = 1; # every 8 cols increment the size of the nullstr,
                      # i.e., decrement max2.  Start off with 1 bit deficit,
                      # since used bit zero for metadata indicator.

        $colcnt = $numcols;

        # Note: treat first pass thru loop special to deal with next
        # ptr, if one exists.  Note that colcnt was already
        # incremented for an extra (next) column, so offset and
        # nullstr positioning should work.
        my $firstpass = $gotnext; 

      L_allcols:
        while ($colcnt > 0)
        {
            my $elt = $firstpass ? $next : ($value->[$colcnt - 1]);
            unless (defined($elt))
            {
#                vec($nullstr, ($colcnt - 1), 1) = 1;
                vec($nullstr, $colcnt, 1) = 1;
                $elt = "";
            }

          L_trypack:
            for my $trypack (1..2)
            {
                if (!$firstpass && scalar(@subargs)) # take substring
                {
                    # Note: but don't take substr of next ptr
                    # (firstpass)
                    
                    {
                        my $pack1 = substr($elt, $subargs[0], $subargs[1]);
                  
#                        greet "foo:", $colcnt, $elt,$trypack,$pack1, @subargs;
      
                        $packstr = pack($PACKVAL_STR, $pack1);
                    }

                }
                else # no substring
                {
                    $packstr = pack($PACKVAL_STR, $elt);
                }

                # max length check
                if (   (defined($max2)) 
                    && (length($packstr) > $max2)
                       )
                {
#                    greet "max: ", $trypack, $max2, $packstr;

                    # XXX: assert trypack == 1 --> 1st try only!!

                    if ($firstpass)
                    {
                        # can't partially pack the next ptr
                        whisper "error: no room for next ptr!";
                        return undef;
                    }

                    # TODO XXX XXX: subtle issue if can pack next ptr, but
                    # cannot pack substring of last element.  Need to
                    # process subargs specially?  
                    # Return subargs[0]+subargs[1]?

                    # don't split column unless greater than 30 bytes

                    if ($max2 <= 6) # need some minimum space
                    {
                        # reset the packed string and 
                        # break if no space left...
                        $packstr = $prevpack; 
                        last L_allcols; 
                    }

                    # else try to pack a substring

                    # NOTE: do substr in reverse, too

                    if (scalar(@subargs))
                    {
                        my $sublen = $subargs[1] - $subargs[0];       

                        my $subadjust = $sublen - ($max2 - 6);

                        $subargs[0] += $subadjust;
                        $subargs[1] -= $subadjust;
#                        greet "z:", @subargs;
                            
                    } # end got subargs
                    else
                    {
                        my $sublen = length($elt) - $max2;
                        $sublen += 6;
                        push @subargs, $sublen;

                        # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
                        # XXX XXX: subtle fencepost error here -- need
                        # to figure this out!  (... + 1) because
                        # substr is zero-based, not 1-based?
                        push @subargs, ($max2 - 6) + 1;
#                        greet "c:", @subargs;
                    }

                    # try again
                    next L_trypack;

                } # end if max2 and len > max2

                if ($trypack > 1)
                {
                    # Note: only do a 2nd try for a column split, so
                    # we must be out of space to pack any more
                    # columns.  Complete the pack string with the
                    # previous packed, and exit the loop over all
                    # columns.
                    $packstr .= $prevpack
                        if (defined($prevpack));

                    # don't increment col cnt, just end
                    last L_allcols;
                }

                # else normal, nonsplit case -- pack succeeded
                @subargs = ()           # clear the subargs
                    if (!$firstpass);   # as long as this wasn't the nextp

                # if we get here, we are done.
                last L_trypack;
            } # end for trypack

#            greet $packstr, $prevpack;

            $max2 -= length($packstr)
                if (defined($max2));

            $packstr .= $prevpack
                if (defined($prevpack));
            $prevpack = $packstr;

            $colcnt--;
            $cnt8++;
            if ($cnt8 >= 8)
            {
                $cnt8 = 0;
                $max2--
                    if (defined($max2));
            }

            $firstpass = 0;
        } # end while colcnt
    } # end if numcols

    if ($colcnt > 0)
    { # split row
#        whisper "overflow";
#    print unpack("b*", $nullstr), "\n";

        my $packcols = $numcols - $colcnt;

        if (scalar(@subargs))
        {
#            greet "ov: ",$packcols, $numcols, $colcnt, @subargs;
            $packcols++; # increase the "packed" columns, even though
                         # we didn't pack a complete column
        }

#        my $packbits = 8 * (($packcols < 8) ? 1 : (int($packcols/8) + 1));
        my $packbits = PackBits($packcols);

        my $nstr = pack("B*", "0"x$packbits); # bitvec of null columns
        my $c2 = $numcols;

        # next ptr thing...
        my $firstpass = $gotnext; 

        while ($c2 > 0)
        {
            my $elt = $firstpass ? $next : $value->[$c2 - 1];
            unless (defined($elt))
            {
#                vec($nstr, (($c2 - $colcnt) - 1), 1) = 1;
                vec($nstr, ($c2 - $colcnt), 1) = 1;
            }
            $c2--;
            $firstpass = 0;
        }

        return undef
            unless (defined($packstr));
        my $headstr = pack($PACK_NUMCOL, $packcols);
#        $headstr .= pack($PACKVAL_STR, $nstr);
        $headstr .= $nstr;
        $headstr .= $packstr
            if (defined($packstr));
        push @outi, $headstr;
        if (scalar(@subargs))
        {
            # XXX XXX: push substr if substr
            $colcnt .= '/' . $subargs[0];
        }
        push @outi, $colcnt;
        if (scalar(@subargs))
        {
            push @outi, "F"; # fragmented
        }

    } # end split row
    else
    {
#        whisper "fits";
#    print unpack("b*", $nullstr), "\n";
#        $headstr .= pack($PACKVAL_STR, $nullstr);
        $headstr .= $nullstr;
        $headstr .= $packstr
            if (defined($packstr));
        push @outi, $headstr;
    }

    return @outi;

} # end packrow2

sub UnPackRow
{
    my ($packstr, $templ_arr) = @_;

#   whoami;
    # whisper "bad!" unless (defined($packstr));

    my $numcols = unpack($PACK_NUMCOL, $packstr);

    my @outarr ;

#    return @outarr
#        unless ($numcols);

    my $templ;
    
    if (defined($templ_arr)) # see if unpack template was predefined
    {
        if (exists($templ_arr->[$numcols]))
        {
            $templ = $templ_arr->[$numcols];
        }
    }

    unless (defined($templ))
    {
        my $skippy = _numcol_len($numcols); # byte length of the column count

        $templ     = "x$skippy "; # unpack template to skip column count bytes

        my $nullvec_len = PackBits($numcols) / 8; # byte length of null vector

        # build string to unpack each column
        $templ  .= "a$nullvec_len ";               # unpack the null bitvec
        $templ  .= "$UnPACKVAL_TYPE " x $numcols;  # unpack other cols
    }
    # skip the column count before each col
    @outarr = unpack($templ, $packstr);

    my $nullstr = shift @outarr;

 #   prints co1,col2...   
#    print unpack("b*", $nullstr), "\n";
    foreach my $colcnt (0..($numcols - 1))
    {
        if (vec($nullstr, $colcnt+1, 1) == 1)
        {
#            print "$colcnt\n";
#   print unpack("b*", $nullstr), "\n";
            $outarr[$colcnt] = undef;
        }
    }

    return (@outarr);
}

sub FileGetHeaderInfo
{
#    whoami;
    my %optional = (
                    fh_offset => 0
                    );
    my %required = (
                    filehandle => "no filehandle!",
                    filename   => "no filename!"
                    );

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

    die unless (exists($args{filehandle}));
    die unless (exists($args{filename}));
                    
    my $fh        = $args{filehandle};
    my $fname     = $args{filename};
    my $fh_offset = $args{fh_offset};

    my $buf;
    my $maxHeadersize = $ALIGN_BLOCKSIZE; # was 2048;
    my $hdrsize       = 0;

    $fh_offset = 0 # seek starts at beginning of file
        unless (defined($fh_offset));

    sysseek ($fh, $fh_offset, 0 )
        or die "bad seek - file $fname : $! \n";

    gnz_read ($fh, \$buf, $maxHeadersize)
        == $maxHeadersize
            or die "bad read - file $fname : $! \n";

    my @val;

    if (0) # wait until Z template is fixed in 5.7
    {
        @val = unpack("Z*N", $buf);

#        greet @val;
    }
    else
    {      # find the null terminator, grab the string and checksum
#        greet $buf;
        my @ggg =  split(/\0/, $buf, 2);

#        greet @ggg;

        die "no null terminator!"
            unless (scalar(@ggg) > 1);

        $val[0] = $ggg[0];
        $val[1] = unpack("N", $ggg[1]);
#        greet @val;
    }

    my $hstr  = shift @val;
    my $cksum = shift @val;

    warn "invalid checksum for file header - file $fname\n"
        unless ($cksum == (unpack("%32C*", $hstr) % 65535));

    my @tok = split(/\s+/, $hstr);

    my $filetype = shift @tok;
    my ($version, $blocksize);

    return undef
        unless (defined($filetype) && ($filetype =~ m/^GNZO$/));

    my %h1;

    for my $t1 (@tok)
    {
        my @kv = split(/=/, $t1);
#        print $kv[0]," ",$kv[1],"\n";

        my $kk = $kv[0];
        my $vv = $kv[1];
        # URL-style substitution to handle spaces, weird chars
        $kk =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/seg;
        $vv =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/seg;

        $h1{$kk} = $vv; # hash of all key values
    }

    $version   = $h1{V};
    $blocksize = $h1{bsz};

    # add 1 byte for null terminator
    $hdrsize = length($hstr) + length(pack("N", 0)) + 1;
    $hdrsize = 64                   # boost to minimum of 64
        if ($hdrsize < 64);
#    print "hdr: ", $hdrsize, "\n";

  # $hdrsize += $fh_offset; # need overall offset to block zero for BCFile...

    return ($hdrsize, $version, $blocksize, \%h1);
}

sub FileSetHeaderInfo
{
#    whoami;
    my %optional = (
                    fh_offset => 0
                    );
    my %required = (
                    filehandle => "no filehandle!",
                    filename   => "no filename!",
                    newkey     => "no key!",
                    newval     => "no val!"
                    );

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

    die unless (exists($args{filehandle}));
    die unless (exists($args{filename}));
    die unless (exists($args{newkey}));
    die unless (exists($args{newval}));
                    
    my $fh        = $args{filehandle};
    my $fname     = $args{filename};
    my $fh_offset = $args{fh_offset};

    my ($hdrsize, $version, $blocksize, $h1) =
        FileGetHeaderInfo(filehandle => $fh, 
                          filename   => $fname,
                          fh_offset  => $fh_offset);

#    print "\n$hdrsize\n";

    my $buf;

    sysseek ($fh, $fh_offset, 0 )
        or die "bad seek - file $fname : $! \n";

    gnz_read ($fh, \$buf, $hdrsize)
        == $hdrsize
            or die "bad read - file $fname : $! \n";

    my @val;

    if (0) # wait until Z template is fixed in 5.7
    {
        @val = unpack("Z*N", $buf);

#        greet @val;
    }
    else
    {      # find the null terminator, grab the string and checksum
#        greet $buf;
        my @ggg =  split(/\0/, $buf, 2);

#        greet @ggg;

        die "no null terminator!"
            unless (scalar(@ggg) > 1);

        $val[0] = $ggg[0];
        $val[1] = unpack("N", $ggg[1]);
#        greet @val;
    }

    my $hstr  = shift @val;
    my $cksum = shift @val;

    my $kk = $args{newkey};
    my $vv = $args{newval};
    # URL-style substitution to handle spaces, weird chars
    $kk =~ s/([^a-zA-Z0-9])/uc(sprintf("%%%02lx",  ord $1))/eg;
    $vv =~ s/([^a-zA-Z0-9])/uc(sprintf("%%%02lx",  ord $1))/eg;

    if (exists($h1->{$args{newkey}}))
    {
        # update an existing pair
        my $oldval = $h1->{$args{newkey}};
        $oldval =~ s/([^a-zA-Z0-9])/uc(sprintf("%%%02lx",  ord $1))/eg;

        my $oldpair = " " . $kk ."=" . $oldval . " ";
        my $kvpair = " " . $kk ."=" . $vv . " ";

        my $len_dif = length($oldpair) - length($kvpair);
        
        if ($len_dif >= 0) 
        {
            # old pair is longer

            if ($len_dif)
            {
                # add extra space if necessary
                $hstr .= " " x $len_dif ;
            }
        }
        else
        {
            # new pair is longer
            
            $len_dif *= -1; # normalize

            # check if have enough trailing space for new val
            my $spacelist = " " x ($len_dif + 1);

            return undef
                unless ($hstr =~ m/$spacelist/);

            # truncate the spaces to preserve header length
            my $one_space = " ";
            $hstr =~ s/$spacelist/$one_space/;

        }
        # finally, update the values
        $hstr =~ s/$oldpair/$kvpair/;

        return undef
            unless ($hstr =~ m/$kvpair/);

    }
    else
    {
        # replace trailing spaces with new pair
        my $kvpair = " " . $kk ."=" . $vv . " ";
        my $spacelist = " " x length($kvpair);

        $hstr =~ s/$spacelist/$kvpair/;

        return undef
            unless ($hstr =~ m/$kvpair/);
    }

    $cksum = unpack("%32C*", $hstr) % 65535;

    # write a null terminated string followed by checksum
    my $pack_hdr;
    if (0) # XXX XXX: can fix later
    {
        $pack_hdr = pack("Z*N", $hstr, $cksum) ;
    }
    else
    {
        # Z template is fixed in 5.7
        # ascii string, null byte, checksum
        $pack_hdr = pack("A*xN", $hstr, $cksum) ;
    }

    sysseek ($fh, $fh_offset, 0 )
        or die "bad seek - file $fname : $! \n";

    my $hdr = gnz_write ($fh, $pack_hdr, length($pack_hdr));

    return $pack_hdr;

}

sub GetIndexKeys
{
    my $filter = shift;

    return undef
        unless (exists($filter->{idxfilter}));

    {
        my @arr1 = @{$filter->{idxfilter}};
        #    greet @arr1;

        my $sval = 0; # 0 = seek first idx col
                      # 1 = match relop
                      # 2 = find literal for index key

        my (@startkey, @stopkey);
        my $prevtoken;

        my $colnum;

        for my $token (@arr1)
        {
            unless (defined($token))
            {
                $sval = 0;
                next;
            }

            if (0 == $sval)
            {
                if (exists($token->{col}))
                {
                    $colnum = $token->{col};
                    $sval++;
                }
            }
            elsif (1 == $sval)
            {
                if (exists($token->{op}))
                {
                    $prevtoken = $token;
                    $sval++;
                }
                else
                {
                    $sval = 0;
                }
            }
            elsif (2 == $sval)
            {
                if (exists($token->{literal}))
                {
                    my $t_lit = $token->{literal};
                    my @cleankey;
                    
                    # remove double/single quotes for char strings

                    @cleankey = ($t_lit =~ m/^\"(.*)\"$/);
                    
                    if (scalar(@cleankey))
                    {
                        $t_lit = shift @cleankey;
                    }
                    else 
                    {
                        @cleankey = ($t_lit =~ m/^\'(.*)\'$/);
                        $t_lit = shift @cleankey
                            if (scalar(@cleankey));
                    }

                    if ($t_lit =~ /^\(/)
                    {
                        whisper "expression";
                        $sval = 0;
                        next;
                    }
                    
                    # XXX XXX XXX XXX XXX
                    #if ($self->{pkey_type} eq "n")
                    #{
                    #    # check for numbers...
                    #    unless ($t_lit =~ /\d+/)
                    #    {
                    #        whisper "not a number";
                    #        $sval = 0;
                    #        next;
                    #    }
                    #}
                    # XXX XXX XXX XXX
                    
                    if ($prevtoken->{op} =~ m/^(==|eq)$/)
                    { # equality
                        $startkey[$colnum] = $t_lit;
                        $stopkey[$colnum] = $t_lit;

                        # only need a single equality predicate --
                        # short circuit here
#                        last;
                    }
                    elsif ($prevtoken->{op} =~ m/^(<|lt|le|<=)$/)
                    { # stopkey
#                            if (defined($iKey[1])
 #                               && 
                        $stopkey[$colnum] = $t_lit;
                    }
                    elsif ($prevtoken->{op} =~ m/^(>|gt|ge|>=)$/)
                    { # startkey
                        $startkey[$colnum] = $t_lit;

                    }
                }
                $sval = 0;
            } # end if 2 == sval
            
        } # end for

        my @foo;
        push @foo, \@startkey;
        push @foo, \@stopkey;
        return @foo;

    }

    return undef;

} # end GetIndexKeys

sub setUseRaw
{
    my $val = shift;

    if ($val && !$RAW_IO)
    {
        $RAW_IO = 1;
        my $raw_io_class = "Genezzo::RawIO";
        if (eval "require $raw_io_class")
        {
            my $s1;
            ($s1 = <<'EOF_S1') =~ s/^\#//gm;            
#sub Genezzo::Util::gnz_read_impl(*\$$)
#{
#    my ($filehandle, $scalar, $length) = @_;
#
#    return Genezzo::RawIO::gnz_raw_read($filehandle, $$scalar, $length);
#}
EOF_S1

            my $s2;
            ($s2 = <<'EOF_S2') =~ s/^\#//gm;            
#sub Genezzo::Util::gnz_write_impl(*$$)
#{
#    my ($filehandle, $scalar, $length) = @_;
#
#    return Genezzo::RawIO::gnz_raw_write($filehandle, $scalar, $length);
#}
EOF_S2
            unless (eval $s1)
            {
                carp "$@";
            }
            unless (eval $s2)
            {
                carp "$@";
            }
        }
        else
        {
            croak "failed to load - $raw_io_class\n$@";
        }
    }
    return $RAW_IO;
}
sub getUseRaw
{
    return $RAW_IO;
}

sub gnz_read_impl(*\$$)
{
    my ($filehandle, $scalar, $length) = @_;

    return sysread($filehandle, $$scalar, $length);
}

sub gnz_write_impl(*$$)
{
    my ($filehandle, $scalar, $length) = @_;

    return syswrite($filehandle, $scalar, $length);
}

sub gnz_read(*\$$)
{
    my ($filehandle, $scalar, $length) = @_;

    return gnz_read_impl($filehandle, $$scalar, $length);
}

sub gnz_write(*$$)
{
    my ($filehandle, $scalar, $length) = @_;

    return gnz_write_impl($filehandle, $scalar, $length);
}


# add a message to the mailbag (create the mailbag if necessary)
#
# To: a package name
# From: an object
# Msg:  a message
#
# behavior is rather open.  one message is 'RSVP', where the
# destination should call the FROM object's RSVP method, supplying
# its package name and the destination object
sub AddMail
{
    my %required = (
                    To => "no destination!",
                    From => "no source!",
                    Msg  => "no message!"
                    );
    my %optional = (
                    MailBag => []
                    );

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

    return undef
        unless (Validate(\%args, \%required));

#    whoami;

    my $mailbag = $args{MailBag};

    my $newmsg = {};
    $newmsg->{To} = $args{To};
    $newmsg->{From} = $args{From};
    $newmsg->{Msg} = $args{Msg};

    push @{$mailbag}, $newmsg;

    return $mailbag;
}

# get our messages from the Mailbag.  All mail whose TO address
# matches the supplied ADDRESS is copied onto a separate message list
sub CheckMail
{
    my %required = (
                    MailBag => "no mailbag!",
                    Address => "no address!"
                    );
#    my %optional = (
#                    );

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

    return undef
        unless (Validate(\%args, \%required));

    my $new_mailbag = [];

#    whoami;

    for my $msg (@{$args{MailBag}})
    {
        if ($msg->{To} eq $args{Address})
        {
            push @{$new_mailbag}, $msg;
        }
    }
    
    return $new_mailbag;

}

END { }       # module clean-up code here (global destructor)

## YOUR CODE GOES HERE

1;  # don't forget to return a true value from the file

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

=head1 NAME

Genezzo::Util - Utility functions

=head1 TODO

=over 4

=item Should bundle all data file utility functions, such as FileGetHeaderInfo,
SetHeaderInfo, etc, under separate Util::DataFile module

=item FileGetHeaderInfo: need to handle case of header which exceeds a 
single block.  Probably should keep increasing the buffer size until
find null terminator (within reason).

=item packrow: store metadata in col0 vs trailing col with next ptr

=item packrow: check pack format for a zero len row of zero cols. 
Does it need a nullvec?

=item packrow/unpackrow: in Perl 5.8 could use the nifty repeating
      templates to our advantage.

=item packrow: could generate skiplists as col zero metadata tracking byte
      position and column numbers to speed lookups

=back

=head1 AUTHOR

Jeffrey I. Cohen, jcohen@genezzo.com

=head1 SEE ALSO

L<perl(1)>.

Copyright (c) 2003, 2004, 2005 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
