File Coverage

blib/lib/Marpa/R3/Common.pm

Criterion	Covered	Total	%
statement	72	94	76.6
branch	13	28	46.4
condition	1	6	16.6
subroutine	11	12	91.6
pod	0	6	0.0
total	97	146	66.4

# Marpa::R3 is Copyright (C) 2018, Jeffrey Kegler.
#
# This module is free software; you can redistribute it and/or modify it
# under the same terms as Perl 5.10.1. For more details, see the full text
# of the licenses in the directory LICENSES.
#
# This program is distributed in the hope that it will be
# useful, but it is provided "as is" and without any express
# or implied warranties. For details, see the full text of
# of the licenses in the directory LICENSES.

package Marpa::R3::Common;

# Marpa::R3 "common" methods

use 5.010001;
use warnings;
use strict;
use English qw( -no_match_vars );

use vars qw($VERSION $STRING_VERSION);
$VERSION        = '4.001_053';
$STRING_VERSION = $VERSION;
## no critic(BuiltinFunctions::ProhibitStringyEval)
$VERSION = eval $VERSION;
## use critic

package Marpa::R3::Internal;

use English qw( -no_match_vars );

# Viewing methods, for debugging

my @escape_by_ord = ();
$escape_by_ord[ ord q{\\} ] = q{\\\\};
$escape_by_ord[ ord eval qq{"$_"} ] = $_
    for "\\t", "\\r", "\\f", "\\b", "\\a", "\\e";
$escape_by_ord[0xa] = '\\n';
$escape_by_ord[$_] //= chr $_ for 32 .. 126;
$escape_by_ord[$_] //= sprintf( "\\x%02x", $_ ) for 0 .. 255;

sub Marpa::R3::escape_string {
    my ( $string, $length ) = @_;
    my $reversed = $length < 0;
    if ($reversed) {
        $string = reverse $string;
        $length = -$length;
    }
    my @escaped_chars = ();
    ORD: for my $ord ( map {ord} split //xms, $string ) {
        last ORD if $length <= 0;
        my $escaped_char = $escape_by_ord[$ord] // sprintf( "\\x{%04x}", $ord );
        $length -= length $escaped_char;
        push @escaped_chars, $escaped_char;
    } ## end for my $ord ( map {ord} split //xms, $string )
    @escaped_chars = reverse @escaped_chars if $reversed;
    IX: for my $ix ( reverse 0 .. $#escaped_chars ) {

        # only trailing spaces are escaped
        last IX if $escaped_chars[$ix] ne q{ };
        $escaped_chars[$ix] = '\\s';
    } ## end IX: for my $ix ( reverse 0 .. $#escaped_chars )
    return join q{}, @escaped_chars;
} ## end sub escape_string

sub Marpa::R3::flatten_hash_args {
    my ($hash_arg_array) = @_;
    my %flat_args = ();
    for my $hash_ref (@{$hash_arg_array}) {
        my $ref_type = ref $hash_ref;
        if ( not $ref_type ) {
            return undef, qq{"%s expects args as ref to HASH, got non-reference instead};
        } ## end if ( not $ref_type )
        if ( $ref_type ne 'HASH' ) {
            return undef, qq{"%s expects args as ref to HASH, got ref to $ref_type instead};
        } ## end if ( $ref_type ne 'HASH' )
        ARG: for my $arg_name ( keys %{$hash_ref} ) {
            $flat_args{$arg_name} = $hash_ref->{$arg_name};
        }
    } ## end for my $args (@hash_ref_args)
    return \%flat_args;
}

sub Marpa::R3::exception {
    my $exception = join q{}, @_;
    $exception =~ s/ \n* \z /\n/xms;
    die($exception) if $Marpa::R3::JUST_DIE;
    CALLER: for ( my $i = 0; 1; $i++) {
        my ($package ) = caller($i);
        last CALLER if not $package;
        last CALLER if not 'Marpa::R3::' eq substr $package, 0, 11;
        $Carp::Internal{ $package } = 1;
    }
    Carp::croak($exception, q{Marpa::R3 exception});
}

# Could/should this be made more efficient by caching line starts,
# then binary searching?
sub Marpa::R3::Internal::line_column {
    my ( $p_string, $pos ) = @_;
    state $EOL = "\n";
    my $line = () = substr( ${$p_string}, 0, $pos ) =~ /$EOL/g;
    my $column = $line ? $pos - $+[0] + 1 : $pos + 1;
    return [$line+1, $column];
}

# Returns a one-line string that is the escaped equivalent
# of its arguments, and whose length is at most $max.
# Returns a list of two elements: the escaped string and
# a boolean indicating if it was truncated
sub Marpa::R3::Internal::substr_as_line {
    my ( $p_string, $pos, $length, $max ) = @_;
    my $truncated     = 0;
    my $used          = 0;
    my @escaped_chars = ();
    my $trailing_ws   = 0;
    my $last_ix = $max > $length ? $pos + $length : $pos + $max;
  CHAR: for ( my $ix = $pos ; $ix <= $last_ix ; $ix++ ) {
        last CHAR if $used >= $max;
        my $char = substr ${$p_string}, $ix, 1;
        $trailing_ws = $char =~ /\s/ ? $trailing_ws + 1 : 0;
        my $ord = ord $char;
        my $escaped_char = $escape_by_ord[$ord] // sprintf( "\\x{%04x}", $ord );

        # say STDERR "ord=$ord $escaped_char";
        $used += length $escaped_char;
        push @escaped_chars, $escaped_char;
    }
    while ( $trailing_ws-- ) {
        my $ws_char = pop @escaped_chars;
        $used -= length $ws_char;
    }
    while ( $used > $max ) {
        my $excess_char = pop @escaped_chars;
        $used -= length $excess_char;
        $truncated = 1;
    }
    return ( join q{}, @escaped_chars ), $truncated;
}

# Returns a two-line summary of a substring --
# a first line with descriptive information and
# a one-line escaped version, indented 2 spaces
sub Marpa::R3::Internal::substr_as_2lines {
    my ( $what, $p_string, $pos, $length, $max ) = @_;
    my ($escaped, $trunc) = substr_as_line( $p_string, $pos, $length, $max );
    my ($line_no, $column) = @{line_column( $p_string, $pos)};
    my @pieces = ($what);
    push @pieces, $trunc ? 'begins' : 'is';
    push @pieces, qq{at line $line_no, column $column:};
    my $line1 = join q{ }, @pieces;
    return "$line1\n  $escaped";
}

1;

# vim: set expandtab shiftwidth=4: