File Coverage

blib/lib/Data/Reuse.pm

Criterion	Covered	Total	%
statement	113	117	96.5
branch	51	62	82.2
condition	5	12	41.6
subroutine	15	16	93.7
pod	3	4	75.0
total	187	211	88.6

package Data::Reuse;

# runtime settings we need
use 5.008001;
use strict;
use warnings;

# set up version info
our $VERSION= '0.13';

# 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 Encode       qw( encode_utf8 );
use Scalar::Util qw( reftype );

=for Explanation:
     Since Data::Alias uses Exporter, we might as well do that also.  Otherwise
     we'd probably hack an import method ourselves

=cut

use base 'Exporter';
our @EXPORT=      qw();
our @EXPORT_OK=   qw( alias 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
    alias 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;

=for Explanation:
     We need to use copy semantics, because aliasing semantics segfaults.
     Or as Matthijs put it:
=
 Hah, het is een combinatie van:
 1. bug in perl m.b.t. \-prototypes (\[$%@] in dit geval)
 2. de refgen operator van Data::Alias (de impliciete \)
 3. het in void context zijn van dit blok
 4. totaal gebrek aan argument-checking in Internals::SvREADONLY
 het prototype maakt van:
=
   Internals::SvREADONLY my @array, 1
=
 zoiets als:
=
   &Internals::SvREADONLY(\my @array, 1);
=
 Echter hij markeert de \ zonder enige context.  Dit hoort normaal alleen
 de gebeuren voor de laatste expressie in een block, en betekent "evalueer
 dit in de context van deze block".  In dit geval is het omliggende block
 de top-level code, en die is altijd in void context.  Perl evalueert dus
 de \ in void context.
=
 Hier ben je echter in perl zelf geen last van, omdat perl's ingebouwde
 refgen op (\) alleen maar test op list-context, en gaat er van uit dat
 het anders scalar context is.  D::A's refgen onderscheid alle drie de
 contexts, en produceert dus niets omdat het in void context is.
=
 Hierdoor wordt de call dus:
=
   &Internals::SvREADONLY(1);
=
 En zoals ik al zei, Internals::SvREADONLY heeft geen argument validatie
 en probeert dus fijn op adres 0x00000001 te lezen.. SEGV

=cut

                                # 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 {
                        	$id = md5( $S . $_ );
			}

=for Explanation:
     When called in void context, perl may actually have used a memory location
     for a temporary data structure that may return later with a different
     content.  As we don't want to equate those two different structures, we
     are not going to save this reference if called in void context.  And we
     are also not going to overwrite anything that's there already.

=cut
                        $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";
        }
    };

    return;
} #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";
        }
    };

    return;
}    #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;

    return;
} #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( encode_utf8( $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__