Data::Reuse - share constant values with Data::Alias

 use Data::Reuse qw(fixate);
 fixate my @array => ( 0, 1, 2, 3 );  # initialize and fixate
 my @filled_array =  ( 0, 1, 2, 3 );
 fixate @filled_array;                # fixate existing values
 print \$array[0] == \$filled_array[0]
   ? "Share memory\n" : "Don't share memory\n";

 fixate my %hash => ( zero => 0, one => 1, two => 2, three => 3 ); 
 my %filled_hash =  ( zero => 0, one => 1, two => 2, three => 3 );
 fixate %filled_hash;
 print \$hash{zero} == \$filled_hash{zero}
   ? "Share memory\n" : "Don't share memory\n";

 use Data::Reuse qw(reuse);
 reuse my $listref = [ 0, 1, 2, 3 ];
 reuse my $hashref = { zero => 0, one => 1, two => 2, three => 3 };
 print \$listref->[0] == \$hashref->{zero}
   ? "Share memory\n" : "Don't share memory\n";

 use Data::Alias qw(alias);
 use Data::Reuse qw(reuse);
 alias my @foo = reuse ( 0, 1, 2, 3 );
 print \$foo[0] == \$hashref->{zero}
   ? "Share memory\n" : "Don't share memory\n";

 use Data::Reuse qw(spread);
 spread my %spread_hash => undef, qw(foo bar baz);
 print \$spread_hash{foo} == \$spread_hash{bar}
   ? "Share memory\n" : "Don't share memory\n";
 spread my @spread_array => 1, 0 .. 3;
 print \$spread_array[0] == \$spread_array[1]
   ? "Share memory\n" : "Don't share memory\n";

 use Data::Reuse qw(forget);
 forget();  # free memory used for tracking constant values

 fixate my @array => ( 0, 1, 2, 3 );

 my @filled_array = ( 0, 1, 2, 3 );
 fixate @filled_array;

 fixate my %hash => ( zero => 0, one => 1, two => 2, three => 3 );

 my %filled_hash = ( zero => 0, one => 1, two => 2, three => 3 );
 fixate %filled_hash;

 my $listref = reuse [ 1, 2, 3 ];
 my $hashref = reuse { one => 1, two => 2, three => 3 };

 my @list = ( 1, 2, 3 );
 my %hash = ( one => 1, two > 2, three => 3 );
 reuse \@list, \%hash;

 spread @array => 1, ( 0, 1, 2, 3 );

 spread %hash => undef, qw(foo bar baz);

 alias @hash{ qw(foo bar baz) } = ();

 spread %hash => undef, qw(foo bar baz);

 use Data::Reuse qw(reuse);

 my $sth = $dbh->prepare( <<"SQL" );
 SELECT room_id, date, rate_id, price, rooms
   FROM inventory
  WHERE date BETWEEN '$first_date' AND '$last_date'
    AND hotel_id = $hotel_id
  ORDER BY date
 SQL
 my $sth->execute;

 my ( $room_id, $date, $rate_id, $price, $rooms );
 $sth->bind_columns( \( $room_id, $date, $rate_id, $price, $rooms ) );

 my %result;
 push @{ $result{$room_id} }, reuse [ $date, $rate_id, $price, $rooms ]
   while $sth->fetch;

 reuse my @list = ( 1, 2, 3 );

 reuse ( 1, 2, 3 );
 my @list = ( 1, 2, 3 );

 my @list = reuse( 1, 2, 3);

 use Data::Reuse qw(alias reuse);
 alias my @list = reuse( 1, 2, 3);

 Data::Alias (1.07)

package Data::Reuse;

# set up version info
BEGIN {
    $VERSION = '0.06';
}    #BEGIN

# be as strict and verbose as possible
use strict;
use warnings;

# we need this otherwise nothing works
use Data::Alias qw(alias copy);

# other modules we need
use Carp qw(croak);
use Digest::MD5 qw(md5);
use Scalar::Util qw(reftype);

use base 'Exporter';
our @EXPORT      = qw();
our @EXPORT_OK   = qw(fixate forget reuse spread);
our %EXPORT_TAGS = (all => \@EXPORT_OK);

# ID prefixes
my $U = "\1U\1";
my $S = "\1S\1";
my $A = "\1A\1";
my $H = "\1H\1";

# set up data store with predefined ro undef value
my %reuse;
forget();

# mark constants as read only
Internals::SvREADONLY $_, 1 foreach ( $U, $S, $A, $H );

# recursion level
my $level = 0;

# references being handled
my %handling;

# satisfy -require-
1;

#---------------------------------------------------------------------------
# reuse
#
# Make given values, store them in the constant hash and return them
#
#  IN: 1..N values to be folded into constants
# OUT: 1..N same as input, but read-only and folded

sub reuse (@); # needed because of recursion
sub reuse (@) {

    # being called with return values
    my $not_void = defined wantarray;

    # we're one level deeper
    $level++;

    # there are values specified that haven't been folded yet or are undef
    if ( alias my @special = grep { !defined or !exists $reuse{$_} } @_ ) {

        # values specified that haven't been folded yet
        if ( alias my @new = grep { defined() } @special ) {
            foreach (@new) { # natural aliasing

                # reference being handled, make sure it is known
                if ( exists $handling{$_} ) {
                     alias $reuse{$_} ||= $_;
                }

                # handle references
                elsif ( my $reftype = reftype $_ ) {
                    $handling{$_} = $level;
                    my $id;

                    # aliasing everything in here
                    alias {

                        # all elements of list
                        if ( $reftype eq 'ARRAY' ) {
                            $id = _list_id( $_ );

                            # not seen, recurse
                            if ( !exists $reuse{$id} ) {
                                my @list = @{$_};
                                (@list) = reuse @list;

                                # mark readonly, see above
                                copy Internals::SvREADONLY @list, 1;

                                # recursive structures may be replaced
                                $id = _list_id( $_ );
                            }
                        }

                        # all values of hash
                        elsif ( $reftype eq 'HASH' ) {
                            $id = _hash_id( $_ );

                            # not seen, recurse, set result if first
                            if ( !$reuse{$id} ) {
                                my %hash = %{$_};
                                ( @hash{ keys %hash } ) = reuse values %hash;

                                # mark readonly, see above
                                copy Internals::SvREADONLY %hash, 1;

                                # recursive structures may be replaced
                                $id = _hash_id( $_ );
                            }
                        }

                        # the value of a scalar ref
                        elsif ( $reftype eq 'SCALAR' ) {
                            my $scalar = ${$_};

                            # may be reused
                            if ( defined $scalar ) {
                                $id = md5( $S . $scalar );

                                # not seen, recurse, set result if first
                                if ( !$reuse{$id} ) {
                                    ($scalar) = reuse $scalar;
                                    copy Internals::SvREADONLY $scalar, 1;

                                    # recursive structures may be replaced
                                    $id = md5( $S . $scalar );
                                }
                            }

                            # always reuse the default undef value
                            else {
                                $id = $U;
                            }
                        }

                        # huh?
                        else {
                            croak "Cannot reuse '$reftype' references";
                        }

                        $reuse{$id} ||= $_ if $not_void;

                        # store in data store
                        $reuse{$_} = $reuse{$id} || $_;
                    };   #alias

                    # done handling this ref
                    delete $handling{$_};
                }

                # not a ref, but now already in store
                elsif ( exists $reuse{$_} ) {
                }

                # not a ref, and not in store either
                else {

                    # not readonly already, make a read only copy
                    $_ = $_, Internals::SvREADONLY $_, 1
                      if !Internals::SvREADONLY $_;

                    # store in data store
                    alias $reuse{$_} = $_;
                }
            }
        }
    }

    # done on this level
    $level--;

    # return aliases of the specified values if needed
    alias return @reuse{ map { defined() ? $_ : $U } @_ } if $not_void;
}    #reuse

#---------------------------------------------------------------------------
# fixate
#
# Fixate the values of the given hash / array ref
#
#  IN: 1 hash / array ref
#      2..N values for fixation

sub fixate (\[@%]@) {

    # fetch structure
    alias my $struct = shift;
    croak "Must specify a hash or array as first parameter to fixate"
      unless my $reftype = reftype $struct;

    # just fixate existing structure
    reuse($struct), return if !@_;

    # alias semantices from here on
    alias {

        # it's a hash
        if ( $reftype eq 'HASH' ) {
            my %hash = %{$struct};
            croak "Can only fixate specific values on an empty hash"
              if keys %hash;

            # fill the hash and make sure only its values are reused
            (%hash) = @_;
            reuse \%hash; # also makes hash ro
        }

        # it's is an array
        elsif ( $reftype eq 'ARRAY' ) {
            my @array = @{$struct};
            croak "Can only fixate specific values on an empty array"
              if @array;

            # fill the array and make sure its values are reused
            (@array) = reuse @_;
            copy Internals::SvREADONLY @array, 1; # must copy, see above
        }

        # huh?
        else {
            croak "Don't know how to fixate '$reftype' references";
        }
    };
} #fixate

#---------------------------------------------------------------------------
# spread
#
# Spread a shared constant value in a data structure
#
#  IN: 1 data structure (hash / array ref)
#      2 value to be set (default: undef )
#      3..N keys / indexes to set

sub spread (\[@%]@) {

    # find out where to spread
    alias my $struct = shift;
    croak "Must specify a hash or array as first parameter to spread"
      unless my $reftype = reftype $struct;

    # huh? no value?
    croak "Must specify a value as second parameter to spread"
      if !@_;

    # fetch proper constant alias
    alias my $value = reuse shift;

    # nothing to be done
    return if !@_;

    # alias semantics from here on
    alias {

        # it's a hash, but can we do it?
        if ( $reftype eq 'HASH' ) {
            my %hash = %{$struct};
            croak "Cannot spread values in a restricted hash"
              if Internals::SvREADONLY %hash;

            # spread the values in the hash
            $hash{$_} = $value foreach @_;
        }

        # it's an array, but can we do it?
        elsif ( $reftype eq 'ARRAY' ) {
            my @array = @{$struct};
            croak "Cannot spread values in a restricted array"
              if Internals::SvREADONLY @array;

            # spread the values in the list
            $array[$_] = $value foreach @_;
        }

        # huh?
        else {
            croak "Don't know how to spread values in '$reftype' references";
        }
    };
}    #spread

#---------------------------------------------------------------------------
# forget
#
# Forget about the values that have been reused so far, or since the last
# time "forget" was called.

sub forget {

    # copy a fresh undef value (shouldn't alias the system undef!)
    %reuse = ( $U => undef );

    # make sure this undef can't be changed
    Internals::SvREADONLY $reuse{$U}, 1;
} #forget

#---------------------------------------------------------------------------
#
# Internal methods
#
#---------------------------------------------------------------------------
# _hash_id
#
# Return the ID for a hash ref
#
#  IN: 1 hash ref
# OUT: 1 id

sub _hash_id {
    alias my %hash = %{ $_[0] };

    return md5( $H . join $;,
      map { $_ => ( defined $hash{$_} ? $hash{$_} : $U ) } sort keys %hash );
}    #_hash_id

#---------------------------------------------------------------------------
# _list_id
#
# Return the ID for a list ref
#
#  IN: 1 list ref
# OUT: 1 id

sub _list_id {
    alias my @list = @{ $_[0] };

    return md5( $A . join $;, map { defined() ? $_ : $U } @list );
}    #_list_id

#---------------------------------------------------------------------------
#
# Debug methods
#
#---------------------------------------------------------------------------
# _constants
#
# Return hash ref of hash containing the constant values
#
# OUT: 1 hash ref

sub _constants { return \%reuse } #_constants

#---------------------------------------------------------------------------

__END__