File Coverage

blib/lib/Audit/DBI/Utils.pm

Criterion	Covered	Total	%
statement	130	146	89.0
branch	56	78	71.7
condition	15	27	55.5
subroutine	19	19	100.0
pod	6	6	100.0
total	226	276	81.8

package Audit::DBI::Utils;

use strict;
use warnings;

use Carp;
use Class::Load;
use Data::Dumper;
use Data::Validate::Type;


=head1 NAME

Audit::DBI::Utils - Utilities for the Audit::DBI distribution.


=head1 VERSION

Version 1.8.2

=cut

our $VERSION = '1.8.2';


=head1 SYNOPSIS

	use Audit::DBI::Utils;

	my $ip_address = Audit::DBI::Utils::integer_to_ipv4( $integer );

	my $integer = Audit::DBI::Utils::ipv4_to_integer( $ip_address );

	my $differences = Audit::DBI::Utils::diff_structures(
		$data_structure_1,
		$data_structure_2,
		comparison_function => sub { my ( $a, $b ) = @_; $a eq $b; }, #optional
	);

	my $diff_string_bytes = Audit::DBI::Utils::get_diff_string_bytes(
		$differences
	);


=head1 FUNCTIONS

=head2 stringify_data_structure()

	my $string = Audit::DBI::Utils::stringify_data_structure(
		data_structure             => $data_structure,
		object_stringification_map =>
		{
			'Math::Currency' => 'as_float',
		},
	);

=cut

sub stringify_data_structure
{
	my ( %args ) = @_;
	my $data_structure = delete( $args{'data_structure'} );
	my $object_stringification_map = delete( $args{'object_stringification_map'} );
	croak 'The following arguments are not valid: ' . join( ', ', keys %args )
		if scalar( keys %args ) != 0;

	return _stringify_data_structure( $data_structure, $object_stringification_map );
}

sub _stringify_data_structure
{
	my ( $data_structure, $object_stringification_map ) = @_;

	if ( Data::Validate::Type::is_arrayref( $data_structure ) )
	{
		# If we have an array, try to stringify each of the elements.
		return
		[
			map { _stringify_data_structure( $_, $object_stringification_map ) } @$data_structure
		];
	}
	elsif ( Data::Validate::Type::is_hashref( $data_structure ) )
	{
		# First, we try to stringify this object.
		foreach my $class ( keys %$object_stringification_map )
		{
			next if !Data::Validate::Type::is_instance( $data_structure, class => $class );
			my $stringification_method = $object_stringification_map->{ $class };
			next if !$data_structure->can( $stringification_method );
			return $data_structure->$stringification_method();
		}

		# If we haven't found it in our list of stringifiable objects,
		# then we need to investigate the individual keys.
		return
		{
			map
				{ $_ => _stringify_data_structure( $data_structure->{ $_ }, $object_stringification_map ) }
				keys %$data_structure
		};
	}
	else
	{
		return $data_structure;
	}
}


=head2 integer_to_ipv4()

Convert a 32-bits integer representing an IP address into its IPv4 form.

	my $ip_address = Audit::DBI::Utils::integer_to_ipv4( $integer );

=cut

sub integer_to_ipv4
{
	my ( $integer ) = @_;

	return undef
		if !defined( $integer ) || $integer !~ m/^\d+$/;

	return join( '.', map { ( $integer >> 8 * ( 3 - $_ ) ) % 256 } 0..3 );
}


=head2 ipv4_to_integer()

Convert an IPv4 address to a 32-bit integer.

	my $integer = Audit::DBI::Utils::ipv4_to_integer( $ip_address );

=cut

sub ipv4_to_integer
{
	my ( $ip_address ) = @_;

	return undef
		if !defined( $ip_address );

	if ( my ( @bytes ) = $ip_address =~ m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/x )
	{
		if ( ! grep { $_ > 255 } @bytes )
		{
			@bytes = reverse( @bytes );
			my $integer = 0;
			foreach my $exponent ( 0..3 )
			{
				$integer += $bytes[ $exponent ] * 256**$exponent;
			}
			return $integer;
		}
	}

	# Invalid input.
	return undef;
}


=head2 diff_structures()

Return the differences between the two data structures passed as parameter.

By default, if leaf nodes are compared with '==' if they are both numeric, and
with 'eq' otherwise.

An optional I parameter can be used to specify a different
comparison function.

	my $differences = Audit::DBI::Utils::diff_structures(
		$data_structure_1,
		$data_structure_2,
	);

	# Alternative built-in comparison function.
	# Leaf nodes are compared using 'eq'.
	my $diff = Audit::DBI::Utils::diff_structures(
		$data_structure_1,
		$data_structure_2,
		comparison_function => 'eq',
	);

	# Alternative custom comparison function.
	my $diff = Audit::DBI::Utils::diff_structures(
		$data_structure_1,
		$data_structure_2,
		comparison_function => sub
		{
			my ( $variable_1, $variable2 ) = @_;
			# [...]
			return $is_equal;
		}
	);

=cut

sub diff_structures
{
	my ( @args ) = @_;
	return _diff_structures(
		{},
		@args
	);
}

sub _diff_structures_comparison_eq
{
	my ( $variable_1, $variable_2 ) = @_;

	return $variable_1 eq $variable_2;
}

sub _diff_structures_comparison_default
{
	my ( $variable_1, $variable_2 ) = @_;

	# For numbers, return numerical comparison.
	return $variable_1 == $variable_2
		if Scalar::Util::looks_like_number( $variable_1 ) && Scalar::Util::looks_like_number( $variable_2 );

	# Otherwise, use exact string match.
	return $variable_1 eq $variable_2;
}

sub _diff_structures
{
	my ( $cache, $structure1, $structure2, %args ) = @_;
	my $comparison_function = $args{'comparison_function'};

	# make sure the provided equality function is really a coderef
	if ( !Data::Validate::Type::is_coderef( $comparison_function ) )
	{
		if ( defined( $comparison_function ) && ( $comparison_function eq 'eq' ) )
		{
			$comparison_function = \&_diff_structures_comparison_eq;
		}
		else
		{
			$comparison_function = \&_diff_structures_comparison_default;
		}
	}

	# If one of the structure is undef, return
	if ( !defined( $structure1 ) || !defined( $structure2 ) )
	{
		if ( !defined( $structure1 ) && !defined( $structure2 ) )
		{
			return undef;
		}
		else
		{
			return
			{
				old => $structure1,
				new => $structure2
			};
		}
	}

	# Cache memory addresses to make sure we don't get into an infinite loop.
	# The idea comes from Test::Deep's code.
	return undef
		if exists( $cache->{ "$structure1" }->{ "$structure2" } );
	$cache->{ "$structure1" }->{ "$structure2" } = undef;

	# Hashes (including hashes blessed as objects)
	if ( Data::Validate::Type::is_hashref( $structure1 ) && Data::Validate::Type::is_hashref( $structure2 ) )
	{
		my %union_keys = map { $_ => undef } ( keys %$structure1, keys %$structure2 );

		my %tmp = ();
		foreach ( keys %union_keys )
		{
			my $diff = _diff_structures(
				$cache,
				$structure1->{$_},
				$structure2->{$_},
				%args,
			);
			$tmp{$_} = $diff
				if defined( $diff );
		}

		return ( scalar( keys %tmp ) != 0 ? \%tmp : undef );
	}

	# If the structures have different references, since we've ruled out blessed
	# hashes (objects) above (that could have a different blessing with the same
	# actual content), return the elements
	if ( ref( $structure1 ) ne ref( $structure2 ) )
	{
		return
		{
			old => $structure1,
			new => $structure2
		};
	}

	# Simple scalars, compare and return
	if ( ref( $structure1 ) eq '' )
	{
		return $comparison_function->( $structure1, $structure2 )
			? undef
			: {
				old => $structure1,
				new => $structure2
			};
	}

	# Arrays
	if ( Data::Validate::Type::is_arrayref( $structure1 ) )
	{
		my @tmp = ();
		my $max_length = ( sort { $a <=> $b } ( scalar( @$structure1 ), scalar( @$structure2 ) ) )[1];
		for my $i ( 0..$max_length-1 )
		{
			my $diff = _diff_structures(
				$cache,
				$structure1->[$i],
				$structure2->[$i],
				%args,
			);
			next unless defined( $diff );

			$diff->{'index'} = $i;
			push(
				@tmp,
				$diff
			);
		}

		return ( scalar( @tmp ) != 0 ? \@tmp : undef );
	}

	# We don't track other types for audit purposes
	return undef;
}


=head2 get_diff_string_bytes()

Return the size in bytes of the string differences. The argument must be a diff
structure returned by C.

This function has two modes:

=over 4

=item * Relative comparison (default):

In this case, a string change from 'TestABC' to 'TestCDE' is a 0 bytes
change (since there is the same number of characters).

	my $diff_string_bytes = Audit::DBI::Utils::get_diff_string_bytes(
		$diff_structure
	);

=item * Absolute comparison:

In this case, a string change from 'TestABC' to 'TestCDE' is a 6 bytes
change (3 characters removed, and 3 added).

	my $diff_string_bytes = Audit::DBI::Utils::get_diff_string_bytes(
		$diff_structure,
		absolute => 1,
	);

Note that absolute comparison requires L to be installed.

=back

=cut

sub get_diff_string_bytes
{
	my ( $diff_structure, %args ) = @_;

	croak 'Cannot perform string comparison without String::Diff installed, please install first and then retry'
		if $args{'absolute'} && !Class::Load::try_load_class( 'String::Diff' );

	return _get_diff_string_bytes(
		{},
		$diff_structure,
		%args,
	);
}

sub _get_diff_string_bytes
{
	my ( $cache, $diff_structure, %args ) = @_;

	return 0
		if !defined( $diff_structure );

	# Cache memory addresses to make sure we don't get into an infinite loop.
	# The idea comes from Test::Deep's code.
	return undef
		if exists( $cache->{ "$diff_structure" } );
	$cache->{ "$diff_structure" } = undef;

	# A hash can mean that a hash had different keys, or this is a leaf node
	# indicating old/new data.
	if ( Data::Validate::Type::is_hashref( $diff_structure ) )
	{
		# If we have an 'old' and 'new' key, then it's a leaf node.
		if ( exists( $diff_structure->{'new'} ) && exists( $diff_structure->{'old'} ) )
		{
			# If we're performing an absolute comparison, we need to add the data removed
			# to the data added.
			if ( $args{'absolute'} )
			{
				# If both structures are not strings, it means we can't inspect
				# inside to do a finer grained comparison and we can only add their
				# respective sizes.
				return get_string_bytes( $diff_structure->{'new'} ) + get_string_bytes( $diff_structure->{'old'} )
					if !Data::Validate::Type::is_string( $diff_structure->{'new'} )
						|| !Data::Validate::Type::is_string( $diff_structure->{'old'} );

				# If both structures are strings however, then we can diff the
				# strings to find out exactly how much has changed.
				my $diff = String::Diff::diff_fully(
					$diff_structure->{'old'},
					$diff_structure->{'new'},
				);

				my $diff_string_bytes = 0;
				foreach my $line ( @{ $diff->[0] }, @{ $diff->[1] } )
				{
					if ( $line->[0] eq '+' )
					{
						$diff_string_bytes += get_string_bytes( $line->[1] );
					}
					elsif ( $line->[0] eq '-' )
					{
						$diff_string_bytes += get_string_bytes( $line->[1] );
					}
				}
				return $diff_string_bytes;
			}
			# If we're performing a relative comparison, we substract the data removed
			# from the data added.
			else
			{
				return get_string_bytes( $diff_structure->{'new'} ) - get_string_bytes( $diff_structure->{'old'} );
			}
		}
		# Otherwise, we need to explore inside the values.
		else
		{
			my $diff_string_bytes = 0;
			foreach my $value ( values %$diff_structure )
			{
				$diff_string_bytes += _get_diff_string_bytes( $cache, $value, %args );
			}
			return $diff_string_bytes;
		}
	}

	# If we have an array, loop through it.
	if ( Data::Validate::Type::is_arrayref( $diff_structure ) )
	{
		my $diff_string_bytes = 0;
		foreach my $element ( @$diff_structure )
		{
			$diff_string_bytes += _get_diff_string_bytes( $cache, $element, %args );
		}
		return $diff_string_bytes;
	}

	# The above parses entirely a diff structure, if anything didn't match
	# then the diff structure is not valid.
	local $Data::Dumper::Terse = 1;
	croak 'Invalid diff structure: ' . Dumper( $diff_structure );
}


=head2 get_string_bytes()

Return the size in bytes of all the strings contained in the data structure
passed as argument.

	my $string_bytes = Audit::DBI::Utils::get_string_bytes( 'Test' );

	my $string_bytes = Audit::DBI::Utils::get_string_bytes(
		[ 'Test1', 'Test2' ]
	);

	my $string_bytes = Audit::DBI::Utils::get_string_bytes(
		{ 'Test' => 1 }
	);

Note: this function is recursive, and will explore both arrayrefs and hashrefs.

=cut

sub get_string_bytes
{
	my ( $structure ) = @_;

	return _get_string_bytes(
		{},
		$structure,
	);
}


sub _get_string_bytes
{
	my ( $cache, $structure ) = @_;

	return 0
		if !defined( $structure );

	# Use bytes pragma to calculate the byte size of the strings correctly.
	use bytes;

	# Strings allow ending the recursion.
	if ( Data::Validate::Type::is_string( $structure ) )
	{
		return bytes::length( $structure );
	}

	# Cache memory addresses to make sure we don't get into an infinite loop.
	# If a loop is detected in the structure, we've counted the size of one
	# cycle at this point and we'll ignore the others.
	return 0 if defined( $cache->{ "$structure" } );
	$cache->{ "$structure" } = 1;

	# For hashrefs, we calculate the size of the keys and the values.
	if ( Data::Validate::Type::is_hashref( $structure ) )
	{
		my $size = 0;
		foreach my $data ( keys %$structure, values %$structure )
		{
			$size += _get_string_bytes( $cache, $data );
		}
		return $size;
	}

	# For arrayrefs, we calculate the size of each element.
	if ( Data::Validate::Type::is_arrayref( $structure ) )
	{
		my $size = 0;
		foreach my $data ( @$structure )
		{
			$size += _get_string_bytes( $cache, $data );
		}
		return $size;
	}

	# If it's not a string, an array, or a hash, we can't retrieve strings
	# from the data structure so we'll ignore it.
	return 0;
}


=head1 BUGS

Please report any bugs or feature requests through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.


=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Audit::DBI::Utils


You can also look for information at:

=over 4

=item * GitHub's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * MetaCPAN

L

=back


=head1 AUTHOR

L,
C<<  >>.


=head1 COPYRIGHT & LICENSE

Copyright 2010-2014 Guillaume Aubert.

This program is free software: you can redistribute it and/or modify it under
the terms of the GNU General Public License version 3 as published by the Free
Software Foundation.

This program is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE. See the GNU General Public License for more details.

You should have received a copy of the GNU General Public License along with
this program. If not, see http://www.gnu.org/licenses/

=cut

1;