Tester gesucht

[pl]

Hallo,

hab einen neuen Serializer entwickelt, derzeit in Testphase für Sessiondateien. Wer Lust, Zeit und Interesse hat, möge mal den damit realisierten Login/Logout testen, siehe "Problematische Seite" Link. Also mal ein paarmal ein/ausloggen.

Es soll nicht umsonst sein, Algorithmus und Source lege ich offen, siehe untenstehend.

MfG

package FreezeHash;

# Recursive serialize for hash of hashes
# ALGORITHMUS
# Die Datenstruktur wird als Baum aufgefasst und rekursiv durchlaufen
# Dabei wird jeder Eintrag erfasst und bekommt eine eigene Entity-ID
# als fortlaufende Nummer. Im Ergebnis dessen entsteht eine lineare
# Struktur: ein einfacher Hash of Hashes nach dem Muster 
# Entity/Attribute/Value kurz EAV
# In der linearisierten Struktur ist für jeden Knoten der parent
# als Attribut hinzugefügt und damit kann die Original-
# Datenstruktur wiederhergestellt werden.

use strict;
use warnings;
use IO::File;
use Fcntl qw(:flock);
use Carp;
use bytes;

#use Data::Dumper;
#$Data::Dumper::Sortkeys = 1;



sub new{
    my $class = shift;
    my %cfg = (
        file => '', # full qualified
        lock => 0,  # atomar read+write
        auto => 0,  # auto write to file
    @_);    

    return eval{
        my $fh = IO::File->new;
        $fh->open( $cfg{file}, O_CREAT|O_BINARY|O_RDWR) ||
            croak "Error open file '$cfg{file}': $!";

        if( $cfg{lock} ){
            flock($fh, LOCK_EX) || 
                carp "Your system does'nt support flock!";
        }
        bless{
            lfdnr => 1,    # root entity
            EAV   => {},
            FH    => $fh ,
            CFG   => \%cfg # for debug
        }, $class;
    };
}

# Linearisierung der geschachtelten Datenstruktur
sub freeze{
    my $self   = shift;
    my $ds     = shift;
    my $parent = shift || $self->{lfdnr};

    # Hash wird rekursiv durchlaufen und linearisiert
    # Jeder Eintrag bekommt eine fortlaufende Nummer
    foreach my $key( keys %$ds ){
        if( ref $ds->{$key} eq 'HASH' ){
            my $ent = $self->_lfdnr(1);
            $self->{EAV}{$ent} = {
                type   => 'HASH',
                att    => $key,
                parent => $parent,
                ent    => $ent
            };
            $self->freeze( $ds->{$key} );
        }
        else{
            my $ent = $self->_lfdnr(1);
            $self->{EAV}{$ent} = {
                parent => $parent,
                type   => 'STRING',
                att    => $key,
                val    => $ds->{$key},
                ent    => $ent
            };
        }
    }

    # ab hier kann serialisiert werden
    # serialisiert wird beim write()-Aufruf
}

# Datenstruktur wiederherstellen
sub thaw{
    my $self = shift;

    # aus Datei deserialisieren, Ergebnis ist
    # eine linearisierte Datenstruktur
    $self->_read;    
    
    # die ursprüngliche Datenstruktur wiederherstellen
    $self->{RESTORED} = {};
    
    # Knoten direkt unterhalb der Wurzel haben entity 1
    foreach my $root( @{$self->{CHILDREN}{1}} ){
        if( $self->{EAV}{$root}{type} eq 'STRING' ){
            $self->{RESTORED}{$self->{EAV}{$root}{att}} = $self->{EAV}{$root}{val};
        }
        else{
            $self->{RESTORED}{$self->{EAV}{$root}{att}} = {};
            foreach my $child ( @{$self->{CHILDREN}{$root}} ){
                $self->_restore($self->{RESTORED}{$self->{EAV}{$root}{att}}, $self->{EAV}{$child});
            }
        }
    }

    return $self->{RESTORED};
}

# Daten in das Handle serialisieren
sub write{
    my $self = shift;
    # STRING kann undef sein, hierzu wird ein byte vergeben 0|1
    # zur Kennzeichnung undef oder String
    $self->{FH}->seek(0,0);
    $self->{FH}->truncate(0);

    foreach my $ent( keys %{$self->{EAV}} ){
        foreach my $att( keys %{$self->{EAV}{$ent}} ){
            my $def = $self->{EAV}{$ent}{$att} ? 1 : 0;
            my $val = $def ? $self->{EAV}{$ent}{$att} : '';
            
            # pack with little endians
            $self->{FH}->print(
                pack('VVV', length $ent, length $att, length $val).$def.$ent.$att.$val
            );
        }    
    }    
    
    return 1;
}

sub DESTROY{
    my $self = shift;
    if( $self->{CFG}{auto} ){ $self->write }
    $self->{FH}->close;
}

#################################### Private ##############################
# wird rekursiv aufgerufen, aus der linearen EAV Struktur
# das Original wiederherstellen
sub _restore{
    my $self = shift;
    my $href = shift; # aktueller stub
    my $hunt = shift; # hash der angefügt werden soll

    if( $hunt->{type} eq 'STRING' ){
        $href->{$hunt->{att}} = $hunt->{val};
    }
    else{
        # hier der rekursive Aufruf
        $href->{$hunt->{att}} = {}; 
        foreach my $child( @{$self->{CHILDREN}{$hunt->{ent}}} ){
            $self->_restore($href->{$hunt->{att}}, $self->{EAV}{$child});
        }
    }
}

# Lese Dateihandle und deserialize
sub _read{
    my $self = shift;
    $self->{FH}->seek(0,0);
    $self->{EAV} = {};
    
    my %CHLD = (); # parent-children relation
    while( read($self->{FH}, my $buffer, 12) ){
        my($elen,$alen,$vlen) = unpack 'VVV', $buffer;
        read($self->{FH}, my $def, 1);
        read($self->{FH}, my $ent, $elen);
        read($self->{FH}, my $att, $alen);
        read($self->{FH}, my $val, $vlen);

        # Korrektur wenn value = undef
        $val = undef if $def eq '0' && $att eq 'val';
        $self->{EAV}{$ent}{$att} = $val;
        
        if( $att eq 'parent' ){
            push @{$CHLD{$val}}, $ent;
        }
    }
    $self->{CHILDREN} = \%CHLD;
}

# Laufende Nummer zur Verwaltung der eigenen Entities
sub _lfdnr{
    my $self = shift;
    my $countup = shift || 0;
    return $countup ? ++$self->{lfdnr} : $self->{lfdnr};
}
1;#########################################################################
__END__
use strict;
use warnings;
use Data::Dumper;
$Data::Dumper::Sortkeys = 1;

# data struct
my $ds = {
    name => 'boo',
    nixdef => undef,
    addr => {
        addr_name  => 'foo',
        addr_vname => 'bar'
    },
    base => {
        base_addr => {
            base_addr_name  => 'foo',
            base_addr_vname => 'bar',
            base_addr_undef => undef,
            base_addr_hash => { base_addr_hash_name => 'otto' },
        },
    },
    #env => \%ENV
};


my $fr = FreezeHash->new( file => 'freeze.bin' ) or die $@;
$fr->freeze( $ds );
$fr->write or die $@;

my $res = $fr->thaw;

print Dumper $res,$ds;