File Coverage

lib/Redis/CappedCollection/Util.pm

Criterion	Covered	Total	%
statement	20	39	51.2
branch	0	14	0.0
condition	0	8	0.0
subroutine	7	9	77.7
pod	2	2	100.0
total	29	72	40.2

package Redis::CappedCollection::Util;

=head1 NAME

Redis::CappedCollection::Util - String manipulation utilities.

=head1 VERSION

This documentation refers to C version 1.08

=cut

#-- Pragmas --------------------------------------------------------------------

use 5.010;
use strict;
use warnings;

# ENVIRONMENT ------------------------------------------------------------------

our $VERSION = '1.08';

use Exporter qw(
    import
);

our @EXPORT_OK  = qw(
    &format_message
    &format_reference
);

#-- load the modules -----------------------------------------------------------

use overload;
use Carp;
use Data::Dumper ();

#-- declarations ---------------------------------------------------------------

=head1 SYNOPSIS

    use 5.010;
    use strict;
    use warnings;

    use Redis::CappedCollection::Util qw( format_message );
    $string = format_message( 'Object %d loaded. Status: %s', $id, $message );

=head1 DESCRIPTION

String manipulation utilities.

=cut

#-- public functions -----------------------------------------------------------

=head1 EXPORTED FUNCTIONS

Use these functions by importing them into your package or by calling a fully-qualified method name.

=cut

=head2 format_reference

    say format_reference( $object );

Dumps reference using preconfigured L. Produces less verbose
output than default L settings.

=cut

my $dumper;
my $empty_array = [];

sub format_reference {
    my ( $value ) = @_;

    unless( $dumper ) {
        $dumper = Data::Dumper->new( $empty_array )
            ->Indent( 0 )
            ->Terse( 1 )
            ->Quotekeys( 0 )
            ->Sortkeys( 1 )
            ->Useperl( 1 )      # XS version seems to have a bug which sometimes results in modification of original object
            ->Sparseseen( 1 )   # speed up since we don't use "Seen" hash
        ;
    }

    my $r;
    if (
            overload::Overloaded( $value ) &&
            overload::Method( $value, '""' )
        ) {
        $r = "$value";  # force stringification
    } else {
        $r = $dumper->Values( [ $value ] )->Dump;
        $dumper->Reset->Values( $empty_array );
    }

    return $r;
}

=head2 format_message

    $string = format_message( 'Object %d loaded. Status: %s', $id, $message );

Returns string formatted using printf-style syntax.

If there are more than one argument and the first argument contains C<%...>
conversions, arguments are converted to a string message using C. In this case, undefined
values are printed as C<<  >> and references are converted to strings using L.

=cut
sub format_message {
    my $format = shift // return;

    my $got = scalar @_;

    return $format unless $got && $format =~ /\%/;

    my $expected = 0;
    while ( $format =~ /(%%|%[^%])/g ) {
        next if $1 eq '%%'; # don't count escape sequence
        ++$expected;
    }

    Carp::cluck "Wrong number of arguments: $expected vs $got" unless $got == $expected;

    return sprintf $format, map {
        !defined $_
            ? ''
            : ref $_
                ? format_reference( $_ )
                : $_
    } @_;
}

#-- private functions ----------------------------------------------------------

1;

__END__