# Serialize.pm -- Serialize in and out arbitrary object graphs to
# ------------    strings.
# September 18, 2000 -- Copyright Sunir Shah. All rights reserved.

# ---------------------------------------------------- GLOBAL FUNCTIONS

package main;

# convertToHttp()
# ---------------
# Takes an ASCII string and converts it to a URL friendly
# string.

sub convertToHttp
{
    my $string = shift;

    return undef if !defined($string);

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

# convertFromHttp()
# -----------------
# Takes an URL friendly string and converts it to a normal
# ASCII string.

sub convertFromHttp
{
    my $string = shift;
    return undef if !defined($string);

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

# --------------------------------------------------- package Serialize

package Serialize;

use Exporter;

@ISA = qw( Exporter );

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

# ---------------------------------------------------------- STREAM OUT

# serializeOut( $component, $indent, $aggregateCallback )
# -------------------------------------------------------
# Streams out $component to a string. It # looks like XML, but it's
# case-sensitive amongst other restrictions (like different tag
# delimiters).
#
# $indent is the current indentation level. It should be made
# of spaces (ASCII 32).
#
# $aggregateCallback is a function to call when an aggregate class
# (a data member that is an instance of a class) is encountered.
# It should take as parameters the object to stream followed by
# the indent. It should return the string representation of the
# object.
#     e.g. $string .= &$aggregateCallback( $object, $indent );

sub serializeOut( $$$ )
{
    my ($component, $indent, $aggregateCallback) = @_;
    $indent = '' unless $indent;
    $aggregateCallback = '_buildObject' unless $aggregateCallback;

    my $string;
    my $ref = ref($component);

    if( grep /$ref/, qw( SCALAR ARRAY HASH CODE GLOB FILEHANDLE NAME PACKAGE ) )
    {
        return _buildComponent( $ref, '', $indent, $aggregateCallback );
    }

    # Actually stream this object out, bypassing the $aggregateCallback.
    return _buildObject( $component, $indent, $aggregateCallback );
}

# _buildStream( $object, $indent, $aggregateCallback )
# ----------------------------------------------------
# Private. Parameters as passed to serializeOut().

sub _buildObject( $$$ )
{
    my ($object, $indent, $aggregateCallback) = @_;
    $aggregateCallback = '_buildObject' unless $aggregateCallback;

    my $string = $indent . "{" . ::convertToHttp(ref($object)) . "}\n";
    my $newIndent = $indent . ' 'x4;

    while( my ($key,$elem) = each %$object )
    {
        $string .= _buildComponent( $elem, $key, $newIndent, $aggregateCallback );
    }

    $string .= "$indent\{/" . ::convertToHttp(ref($object)) . "}\n";

    return $string;
}

# _buildComponent( $component, $tag, $indent, $aggregateCallback )
# ----------------------------------------------------------------
# Private. This is not a method; this a normal function.
# Parameters as passed to serializeOut(). $tag is the name for
# this component. It can be an empty string. Tags starting with
# underscores will not be streamed; they are considered private.

sub _buildComponent( $$$$ )
{
    my ($component, $tag, $indent, $aggregateCallback) = @_;

    # All tags prefixed with an underscore are considered
    # private (actually, they are more likely derived attributes)
    # and won't be streamed.
    return '' if $tag =~ /^_/;

    my $string = '';
    my $newIndent = $indent . ' 'x4;

    # Scalar
    if( !ref($component) )
    {
        $string .= "$indent\<" . ::convertToHttp($tag) . '>';
        $string .= ::convertToHttp($component) . '</' . ::convertToHttp($tag) . ">\n";
    }
    elsif( ref($component) eq 'ARRAY' )
    {
        $string .= "$indent\[" . ::convertToHttp($tag) . "]\n";
        foreach (@$component)
        {
            $string .= _buildComponent( $_, '', $newIndent, $aggregateCallback );
        }

        $string .= "$indent\[/" . ::convertToHttp($tag) . "]\n";
    }
    elsif( ref($component) eq "HASH" )
    {
        $string .= "$indent\#" . ::convertToHttp($tag) . "\#\n";
        while( my ($key, $elem) = each %$component )
        {
            $string .= _buildComponent( $elem, $key, $newIndent, $aggregateCallback );
        }

        $string .= "$indent\#/" . ::convertToHttp($tag) . "\#\n";
    }

    # Aggregate
    elsif( ref($component) )
    {
        # Collections don't provide or require tag names as a
        # readability feature if not an orthoganilty feature.
        if( $tag )
        {
            $string .= "$indent\<" . ::convertToHttp($tag) . ">\n";
            $string .= &$aggregateCallback( $component, $newIndent );
            $string .= "$indent\</" . ::convertToHttp($tag) . ">\n";
        }
        else
        {
            $string .= &$aggregateCallback( $component, $indent );
        }
    }
    else
    {
        die 'Unknown component type: ' . ref($component);
    }

    return $string;
}

# ----------------------------------------------------------- STREAM IN

# serializeIn()
# ----------
# Creates a new object graph based on a string emitted from
# serializeOut(). This is a function, not a method.
#
# If you pass in garbage, this will likely die().

sub serializeIn
{
    my $stream = shift;

    study $stream;

    my @tag_stack;
    my @object_stack = ([]);   # Start with one collection to hold the resultant
		
    # The tag delimiters cannot be valid HTTP characters.
    # Be careful to add the delimiters to the scalar value
    # regexp.
    while( $stream =~ m@ \G \s*               # Start where we left off
            (
                (<\s*/\s*([^>\s]*)\s*>)    |  # </SCALAR>
                (<\s*([^>\s]*)\s*>)        |  # <SCALAR>

                ({\s*/\s*([^}\s]*)\s*})    |  # {/OBJECT}
                ({\s*([^}\s]*)\s*})        |  # {OBJECT}

                (\[\s*/\s*([^\]\s]*)\s*])  |  # [/COLLECTION]
                (\[\s*([^\]\s]*)\s*])      |  # [COLLECTION]

                (\^\s*/\s*([^\^\s]*)\s*\^) |  # ^/DATABASE REFERENCE^
                (\^\s*([^\^\s]*)\s*\^)     |  # ^DATABASE REFERENCE^

                (\#\s*/\s*([^\#\s]*)\s*\#) |  # #/HASH#
                (\#\s*([^\#\s]*)\s*\#)     |  # #HASH#

                ([^\x3C\]\}\^\#]+)            # Scalar value
            ) \s*
        @gx
    )
    {
        my (
            $start_scalar,
            $end_scalar,
            $start_object,
            $end_object,
            $start_collection,
            $end_collection,
            $start_db_reference,
            $end_db_reference,
            $start_hash,
            $end_hash,
            $scalar
        ) = (
            ::convertFromHttp($5),
            ::convertFromHttp($3),
            ::convertFromHttp($9),
            ::convertFromHttp($7),
            ::convertFromHttp($13),
            ::convertFromHttp($11),
            ::convertFromHttp($17),
            ::convertFromHttp($15),
            ::convertFromHttp($21),
            ::convertFromHttp($19),
            ::convertFromHttp($22)
        );

        if( defined($start_scalar) )
        {
            my $scalar;

            push @tag_stack, $start_scalar;
            push @object_stack, \$scalar;
        }

        elsif( defined($end_scalar) )
        {
            {
                my $last_tag = pop @tag_stack;
                die "$end_scalar is mismatched with $last_tag" if $end_scalar ne $last_tag;
            }

            my $scalar = pop @object_stack;

            $$scalar = '' if not defined($$scalar);

            die "Orphaned scalar: $end_scalar"
                if 0 == scalar(@object_stack)
                   or not ref($object_stack[$#object_stack]);

            if( ref($object_stack[$#object_stack]) eq "ARRAY" )
            {
                push @{$object_stack[$#object_stack]}, ($$scalar);
            }
            else
            {
                $object_stack[$#object_stack]->{$end_scalar} = $$scalar;
            }
        }

        elsif( defined($start_object) )
        {
            push @tag_stack, $start_object;
            my $object = bless {}, $start_object;
            push @object_stack, $object;
        }

        elsif( defined($end_object) )
        {
            {
                my $last_tag = pop @tag_stack;
                die "$end_object is mismatched with $last_tag" if $end_object ne $last_tag;
            }

            my $object = pop @object_stack;

            die "Orphaned object: $end_object"
                if 0 == scalar(@object_stack)
                   or not ref($object_stack[$#object_stack]);

            if( ref($object_stack[$#object_stack]) eq "ARRAY" )
            {
                push @{$object_stack[$#object_stack]}, ($object);
            }
            elsif( ref($object_stack[$#object_stack]) eq "SCALAR" )
            {
                # Stuff the object into the scalar reference.
                # Ultimately, the scalar will be dereferenced,
                # so stuff a reference to the object.
                $object_stack[$#object_stack] = \$object;
            }
            else
            {
                $object_stack[$#object_stack]->{$end_object} = $object;
            }
        }

        elsif( defined($start_collection) )
        {
            push @tag_stack, $start_collection;
            push @object_stack, [];
        }

        elsif( defined($end_collection) )
        {

            {
                my $last_tag = pop @tag_stack;
                die "$end_collection is mismatched with $last_tag" if $end_collection ne $last_tag;
            }

            my $collection = pop @object_stack;

            die "Orphaned collection: $end_collection"
                if 0 == scalar(@object_stack)
                   or not ref($object_stack[$#object_stack]);

            if( ref($object_stack[$#object_stack]) eq "ARRAY" )
            {
                push @{$object_stack[$#object_stack]}, ($collection);
            }
            else
            {
                $object_stack[$#object_stack]->{$end_collection} = $collection;
            }
        }

        elsif( defined($start_db_reference) )
        {
            my $primary_key;

            push @tag_stack, $start_db_reference;
            push @object_stack, \$primary_key;
        }

        elsif( defined($end_db_reference) )
        {
            {
                my $last_tag = pop @tag_stack;
                die "$end_db_reference is mismatched with $last_tag" if $end_db_reference ne $last_tag;
            }

            my $primary_key = pop @object_stack;

            die "No primary key specified for $end_db_reference" if !$$primary_key;

            my $object = $end_db_reference->new( $$primary_key );

            die "Orphaned object: $end_db_reference"
                if 0 == scalar(@object_stack)
                   or not ref($object_stack[$#object_stack]);

            if( ref($object_stack[$#object_stack]) eq "ARRAY" )
            {
                push @{$object_stack[$#object_stack]}, $object;
            }
            elsif( ref($object_stack[$#object_stack]) eq "SCALAR" )
            {
                # Stuff the object into the scalar reference.
                # Ultimately, the scalar will be dereferenced,
                # so stuff a reference to the object.
                $object_stack[$#object_stack] = \$object;
            }
            else
            {
                $object_stack[$#object_stack]->{$end_db_reference} = $object;
            }
        }

        elsif( defined($start_hash) )
        {
            push @tag_stack, ($start_hash);
            push @object_stack, {};
        }

        elsif( defined($end_hash) )
        {
            {
                my $last_tag = pop @tag_stack;
                die "$end_hash is mismatched with $last_tag" if $end_hash ne $last_tag;
            }

            my $hash = pop @object_stack;

            die "Orphaned hash: $end_hash"
                if 0 == scalar(@object_stack)
                   or not ref($object_stack[$#object_stack]);

            if( ref($object_stack[$#object_stack]) eq "ARRAY" )
            {
                push @{$object_stack[$#object_stack]}, ($hash);
            }
            elsif( ref($object_stack[$#object_stack]) )
            {
                $object_stack[$#object_stack]->{$end_hash} = $hash;
            }
        }

        elsif( defined($scalar) )
        {
            die "Scalar found in non-scalar context ($scalar)"
                if 0 == scalar(@object_stack)
                   or not ref($object_stack[$#object_stack])
                   or ref($object_stack[$#object_stack]) ne "SCALAR";

            ${$object_stack[$#object_stack]} = $scalar;
        }

        else
        {
            die 'Unknown state in Serialize::serializeIn().';
        }
    }

    die 'Unbalanced tags; someone popped the resultant!' if 0 == scalar(@object_stack);

    return @{pop @object_stack} if wantarray;
    return $object_stack[0][0];
}

1;