# TiedElement.pm -- Maintains the underlying data for an Element.
# --------------    Deals with autoloading off disk; saving to disk.
# September 17, 2000 -- Copyright Sunir Shah. All rights reserved.

package TiedElement;

use Exporter;
use Serialize;

@ISA = qw( Exporter );

@EXPORT = qw();
@EXPORT_OK = qw();
@EXPORT_TAGS = qw();

# ------------------------------------------------------------- GLOBALS

$DatabaseRoot = $main::DatabaseRoot || "g:\\www\\cgi-bin\\crystal\\db";
my %cache;

# ------------------------------------------------------ PUBLIC METHODS

# TIEHASH()
# ---------
# Tie constructor. Takes as parameters
#
#    class          The Element's actual class.
#    primary_key    The primary key of the Element.
#    hash           A reference to the hash being tied.
#
# The hash will be blessed as the target class.

sub TIEHASH
{
    my ($self, $class, $primary_key, $hash) = @_;
    return bless {
        class => $class,
        key => $primary_key,
        hash => $hash
    }, $self;
}

# load()
# ------
# Loads the element from disk or the cache.

sub load
{
    my $self = shift;
    # Return if the element is cached. This makes the Elements Singletons.
    return if $cache{$self->{class}}->{$self->{key}};

    my $object = bless {}, $self->{class};
    $cache{$self->{class}}->{$self->{key}} = $object;
    $self->{hash}->_initialize($self->{key});

    my $RECORD;
    my $path =
        $DatabaseRoot
        . '/'
        . convertToFilename($self->{class})
        . '/'
        . convertToFilename($self->{key})
        . '.tpb';

    if( -e $path )
    {
        open RECORD, '<' . $path or die "Cannot open $path for reading";
            lock( *RECORD );
                my $new = serializeIn( join " ", <RECORD> );
            unlock( *RECORD );
        close RECORD;
        while( my ($key, $elem) = each %$new ) {
            $object->{$key} = $elem;
        }
    }
}

# save()
# ------
# Saves the instance to the database.

sub save
{
    my $self = shift;
    return unless $cache{$self->{class}}->{$self->{key}};

    my $component = $cache{$self->{class}}->{$self->{key}};
    $cache{$self->{class}}->{$self->{key}} = undef;

    my $string = serializeOut(
        $component,
        '',
        'TiedElement::_saveDatabaseReference'
    );

    if( $self->{key} )
    {
        # Create the directory if it doesn't exist

        my $path = $DatabaseRoot . '/' . convertToFilename($self->{class});
        mkdir $path, 0777 unless -e $path;

        my $RECORD;
        $path .= '/' . convertToFilename($self->{key}) . '.tpb';
        open RECORD, '>' . $path or die "Cannot open $path for writing";
            lock( *RECORD );
                print RECORD $string;
            unlock( *RECORD );
        close RECORD;
    }
}

# exists()
# --------
# Returns true if the object exists for the given class.

sub exists
{
    my $class = shift or die "No class to load";
    my $key = shift or return 0;
    my $path = $DatabaseRoot . '/' . convertToFilename($class) . '/' . convertToFilename($key) . '.tpb';
    return -e $path;
}

# ------------------------------------------------ TIED HASH OPERATIONS
#
# All hash operations will load the element off disk into the cache
# if it hasn't been done before and then do the requested operation on
# the data.

sub FETCH
{
    my ($self, $key) = @_;
    load $self;
    return $cache{$self->{class}}->{$self->{key}}->{$key};
}

sub STORE
{
    my ($self, $key, $value) = @_;
    load $self;
    $cache{$self->{class}}->{$self->{key}}->{$key} = $value;
}

sub DELETE
{
    my ($self, $key) = @_;
    load $self;
    delete $cache{$self->{class}}->{$self->{key}}->{$key};
}

sub CLEAR
{
    my $self = shift;
    load $self;
    %{$cache{$self->{class}}->{$self->{key}}} = ();
}

sub EXISTS
{
    my ($self, $key) = @_;
    load $self;
    return exists $cache{$self->{class}}->{$self->{key}}->{$key};
}

sub FIRSTKEY
{
    my $self = shift;
    load $self;
    my $foo = scalar keys %{$cache{$self->{class}}->{$self->{key}}}; # Calling keys in a scalar context resets each.
    return scalar each %{$cache{$self->{class}}->{$self->{key}}};
}

sub NEXTKEY
{
    my $self = shift;
    return scalar each %{$cache{$self->{class}}->{$self->{key}}};
}

# -------------------------------------------- STREAMING HELPER METHODS

# convertToFilename()
# -------------------
# Takes an ASCII string and filters it into a filename.
# There is a guaranteed one-to-one mapping between ASCII
# strings and filenames.

sub convertToFilename
{
    my $string = shift;

    return undef if !defined($string);

    $string =~ s/([^a-zA-Z0-9\-\_])/sprintf("_%02x",ord($1))/ge;
    return $string;
}

# convertFromFilename()
# ---------------------
# Takes a filename and converts it to an ASCII string.
# This undoes filenames created by convertToFilename().

sub convertFromFilename
{
    my $string = shift;

    return undef if !defined($string);

    $string =~ s/_([0-9a-fA-F]{2})/pack('C',oct("0x$1"))/ge;
    return $string;
}

# lock()
# ------
# Locks a file. You must call unlock afterwards.
# WARNING: This will block until the file is available.

sub lock
{
    my $FILE = shift;
    flock FILE, 2; # 2 == exclusive lock
}

# unlock()
# --------
# Unlocks a lock()ed file.

sub unlock
{
    my $FILE = shift;
    flock FILE, 8; # 8 == unlock
}

# _saveDatabaseReference()
# ------------------------
# Private. Called by _buildComponent when it encounters an
# object to store. If the component can be stored, it returns the
# database reference to the component and then stores the component
# in the database. Else, it just streams it out.

sub _saveDatabaseReference()
{
    my ($object, $indent) = @_;
    my $tied = tied %$object or die 'Error: Can only make a database reference to a TiedElement.';
    my $key = $tied->{key} or die 'Cannot store ' . ref($object) . ' without a primary key.';

    my $string = '';
    $string = $indent . '^' . ::convertToHttp(ref($object)) . '^';
    $string .= ::convertToHttp($key);
    $string .= '^/' . ::convertToHttp(ref($object)) . "^\n";

    $tied->save();

    return $string;
}

1;