rtsi.com/2014.01.www.rtsi.com.tar/www.rtsi.com/OS9/FAQ/discus_admin_1357211388/source/storage.pl

Text File | 2009-11-06 | 5KB | 199 lines

# FILE: storage.pl
# DESCRIPTION: Storing and retrieving arrays and hashes in flat text files
#-------------------------------------------------------------------------------
# DISCUS COPYRIGHT NOTICE
#
# Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
# The use of Discus is governed by the Discus License Agreement which is
# available from the Discus WWW site at:
#    http://www.discusware.com/discus/license
#
# Pursuant to the Discus License Agreement, this copyright notice may not be
# removed or altered in any way.
#-------------------------------------------------------------------------------

use strict;
use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);

###
### storage_encode_arguments
###
### Encodes subroutine arguments
###

sub storage_encode_arguments {
    my @args = ();
    my $internal_counter = 0;
    foreach my $k (@_) {
        if (ref $k eq "HASH") {
            my ($u, $l, $ic) = storage_encode_hash($k, ++$internal_counter);
            push @args, join(":", "ARG", "HASH($internal_counter)");
            unshift @args, $u;
            unshift @args, @{ $l };
            $internal_counter = $ic;
        } elsif (ref $k eq "ARRAY") {
            my ($u, $l, $ic) = storage_encode_array($k, ++$internal_counter);
            push @args, join(":", "ARG", "ARRAY($internal_counter)");
            unshift @args, $u;
            unshift @args, @{ $l };
            $internal_counter = $ic;
        } else {
            my $u = join(":", "ARG", escape($k));
            push @args, $u;
        }
    }
    return @args;
}

###
### storage_unencode_arguments
###
### Unencodes an argument list
###

sub storage_unencode_arguments {
    my ($file) = @_;
    my @args = ();
    my @file = @{ $file };
    my $hashes = {};
    my $arrays = {};
    foreach my $line (@file) {
        chomp $line;
        if ($line =~ /^ARRAY(\d+):/) {
            $arrays->{$1} = $';
        } elsif ($line =~ /^HASH(\d+):/) {
            $hashes->{$1} = $';
        } elsif ($line =~ /^ARG:/) {
            my $aft = $';
            if ($aft =~ /^HASH\((\d+)\)/) {
                push @args, storage_unencode_hash($1, $hashes, $arrays)
            } elsif ($aft =~ /^ARRAY\((\d+)\)/) {
                push @args, storage_unencode_array($1, $hashes, $arrays);
            } else {
                if ($aft eq "") {
                    push @args, undef;
                } else {
                    push @args, unescape($aft);
                }
            }
        }
    }
    return @args;
}

###
### storage_unencode_hash
###
### Transforms an encoded hash into an unencoded hash
###

sub storage_unencode_hash {
    my ($hashnum, $hashes, $arrays) = @_;
    my @pairs = split(/&/, $hashes->{$hashnum});
    my $hashout = {};
    foreach my $pair (@pairs) {
        my ($name, $value) = split(/=/, $pair);
        $name = unescape($name);
        if ($value =~ /^HASH\((\d+)\)/) {
            $hashout->{$name} = storage_unencode_hash($1, $hashes, $arrays);
        } elsif ($value =~ /^ARRAY\((\d+)\)/) {
            $hashout->{$name} = storage_unencode_array($1, $hashes, $arrays);
        } else {
            $hashout->{$name} = unescape($value);
        }
    }
    return $hashout;
}

###
### storage_unencode_array
###
### Transforms an encoded array into an unencoded array
###

sub storage_unencode_array {
    my ($hashnum, $hashes, $arrays) = @_;
    my @pairs = split(/&/, $arrays->{$hashnum});
    my @aout = ();
    foreach my $pair (@pairs) {
        my ($name, $value) = split(/=/, $pair);
        if ($value =~ /^HASH\((\d+)\)/) {
            $aout[$name] = storage_unencode_hash($1, $hashes, $arrays);
        } elsif ($value =~ /^ARRAY\((\d+)\)/) {
            $aout[$name] = storage_unencode_array($1, $hashes, $arrays);
        } else {
            $aout[$name] = unescape($value);
        }
    }
    return \@aout;

}

###
### storage_encode_hash
###
### Transforms an unencoded hash into an encoded hash
###

sub storage_encode_hash {
    my ($hash, $ctr) = @_;
    my @k = keys(%{ $hash });
    my @r = ();
    my @o = ();
    my $r = "HASH$ctr";
    foreach my $key (@k) {
        if (ref $hash->{$key} eq "HASH") {
            my ($thathash, $otherhashes, $counter) = storage_encode_hash($hash->{$key}, ++$ctr);
            $ctr = $counter;
            push @r, join("=", escape($key), "HASH($ctr)");
            push @o, $thathash;
            push @o, @{ $otherhashes } if defined $otherhashes;
        } elsif (ref $hash->{$key} eq "ARRAY") {
            my ($thathash, $otherhashes, $counter) = storage_encode_array($hash->{$key}, ++$ctr);
            $ctr = $counter;
            push @r, join("=", escape($key), "ARRAY($ctr)");
            push @o, $thathash;
            push @o, @{ $otherhashes } if defined $otherhashes;
        } else {
            push @r, join("=", escape($key), escape($hash->{$key}));
        }
    }
    return (join(":", $r, join("&", @r)), \@o, $ctr);
}

###
### storage_encode_array
###
### Transforms an unencoded array into an encoded array
###

sub storage_encode_array {
    my ($array, $ctr) = @_;
    my @k = @{$array};
    my @r = ();
    my @o = ();
    my $r = "ARRAY$ctr";
    my $count = 0;
    foreach my $key (@k) {
        if (ref $key eq "HASH") {
            my ($thathash, $otherhashes, $counter) = storage_encode_hash($key, ++$ctr);
            $ctr = $counter;
            push @r, join("=", $count, "HASH($ctr)");
            push @o, $thathash;
            push @o, @{ $otherhashes } if defined $otherhashes;
        } elsif (ref $key eq "ARRAY") {
            my ($thathash, $otherhashes, $counter) = storage_encode_array($key, ++$ctr);
            $ctr = $counter;
            push @r, join("=", $count, "ARRAY($ctr)");
            push @o, $thathash;
            push @o, @{ $otherhashes } if defined $otherhashes;
        } else {
            push @r, join("=", $count, escape($key));
        }
        $count++;
    }
    return (join(":", $r, join("&", @r)), \@o, $ctr);
}

1;