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


line stmt bran cond sub pod time code
1             # Marpa::R3 is Copyright (C) 2018, Jeffrey Kegler.
2             #
3             # This module is free software; you can redistribute it and/or modify it
4             # under the same terms as Perl 5.10.1. For more details, see the full text
5             # of the licenses in the directory LICENSES.
6             #
7             # This program is distributed in the hope that it will be
8             # useful, but it is provided "as is" and without any express
9             # or implied warranties. For details, see the full text of
10             # of the licenses in the directory LICENSES.
11              
12             package Marpa::R3::Common;
13              
14             # Marpa::R3 "common" methods
15              
16 104     104   1839 use 5.010001;
  104         357  
17 104     104   541 use warnings;
  104         280  
  104         2522  
18 104     104   542 use strict;
  104         247  
  104         2724  
19 104     104   628 use English qw( -no_match_vars );
  104         197  
  104         614  
20              
21 104     104   37276 use vars qw($VERSION $STRING_VERSION);
  104         236  
  104         8326  
22             $VERSION = '4.001_053';
23             $STRING_VERSION = $VERSION;
24             ## no critic(BuiltinFunctions::ProhibitStringyEval)
25             $VERSION = eval $VERSION;
26             ## use critic
27              
28             package Marpa::R3::Internal;
29              
30 104     104   793 use English qw( -no_match_vars );
  104         208  
  104         580  
31              
32             # Viewing methods, for debugging
33              
34             my @escape_by_ord = ();
35             $escape_by_ord[ ord q{\\} ] = q{\\\\};
36             $escape_by_ord[ ord eval qq{"$_"} ] = $_
37             for "\\t", "\\r", "\\f", "\\b", "\\a", "\\e";
38             $escape_by_ord[0xa] = '\\n';
39             $escape_by_ord[$_] //= chr $_ for 32 .. 126;
40             $escape_by_ord[$_] //= sprintf( "\\x%02x", $_ ) for 0 .. 255;
41              
42             sub Marpa::R3::escape_string {
43 0     0 0 0 my ( $string, $length ) = @_;
44 0         0 my $reversed = $length < 0;
45 0 0       0 if ($reversed) {
46 0         0 $string = reverse $string;
47 0         0 $length = -$length;
48             }
49 0         0 my @escaped_chars = ();
50 0         0 ORD: for my $ord ( map {ord} split //xms, $string ) {
  0         0  
51 0 0       0 last ORD if $length <= 0;
52 0   0     0 my $escaped_char = $escape_by_ord[$ord] // sprintf( "\\x{%04x}", $ord );
53 0         0 $length -= length $escaped_char;
54 0         0 push @escaped_chars, $escaped_char;
55             } ## end for my $ord ( map {ord} split //xms, $string )
56 0 0       0 @escaped_chars = reverse @escaped_chars if $reversed;
57 0         0 IX: for my $ix ( reverse 0 .. $#escaped_chars ) {
58              
59             # only trailing spaces are escaped
60 0 0       0 last IX if $escaped_chars[$ix] ne q{ };
61 0         0 $escaped_chars[$ix] = '\\s';
62             } ## end IX: for my $ix ( reverse 0 .. $#escaped_chars )
63 0         0 return join q{}, @escaped_chars;
64             } ## end sub escape_string
65              
66             sub Marpa::R3::flatten_hash_args {
67 2710     2710 0 5697 my ($hash_arg_array) = @_;
68 2710         4837 my %flat_args = ();
69 2710         4116 for my $hash_ref (@{$hash_arg_array}) {
  2710         6731  
70 3154         6279 my $ref_type = ref $hash_ref;
71 3154 50       7166 if ( not $ref_type ) {
72 0         0 return undef, qq{"%s expects args as ref to HASH, got non-reference instead};
73             } ## end if ( not $ref_type )
74 3154 50       7439 if ( $ref_type ne 'HASH' ) {
75 0         0 return undef, qq{"%s expects args as ref to HASH, got ref to $ref_type instead};
76             } ## end if ( $ref_type ne 'HASH' )
77 3154         4389 ARG: for my $arg_name ( keys %{$hash_ref} ) {
  3154         10089  
78 3793         11093 $flat_args{$arg_name} = $hash_ref->{$arg_name};
79             }
80             } ## end for my $args (@hash_ref_args)
81 2710         8858 return \%flat_args;
82             }
83              
84             sub Marpa::R3::exception {
85 50     50 0 299 my $exception = join q{}, @_;
86 50         1214 $exception =~ s/ \n* \z /\n/xms;
87 50 100       225 die($exception) if $Marpa::R3::JUST_DIE;
88 48         125 CALLER: for ( my $i = 0; 1; $i++) {
89 198         1114 my ($package ) = caller($i);
90 198 50       511 last CALLER if not $package;
91 198 100       513 last CALLER if not 'Marpa::R3::' eq substr $package, 0, 11;
92 150         311 $Carp::Internal{ $package } = 1;
93             }
94 48         7134 Carp::croak($exception, q{Marpa::R3 exception});
95             }
96              
97             # Could/should this be made more efficient by caching line starts,
98             # then binary searching?
99             sub Marpa::R3::Internal::line_column {
100 10     10 0 20 my ( $p_string, $pos ) = @_;
101 10         14 state $EOL = "\n";
102 10         13 my $line = () = substr( ${$p_string}, 0, $pos ) =~ /$EOL/g;
  10         73  
103 10 50       48 my $column = $line ? $pos - $+[0] + 1 : $pos + 1;
104 10         39 return [$line+1, $column];
105             }
106              
107             # Returns a one-line string that is the escaped equivalent
108             # of its arguments, and whose length is at most $max.
109             # Returns a list of two elements: the escaped string and
110             # a boolean indicating if it was truncated
111             sub Marpa::R3::Internal::substr_as_line {
112 10     10 0 21 my ( $p_string, $pos, $length, $max ) = @_;
113 10         15 my $truncated = 0;
114 10         14 my $used = 0;
115 10         14 my @escaped_chars = ();
116 10         15 my $trailing_ws = 0;
117 10 50       24 my $last_ix = $max > $length ? $pos + $length : $pos + $max;
118 10         30 CHAR: for ( my $ix = $pos ; $ix <= $last_ix ; $ix++ ) {
119 244 50       403 last CHAR if $used >= $max;
120 244         286 my $char = substr ${$p_string}, $ix, 1;
  244         379  
121 244 100       525 $trailing_ws = $char =~ /\s/ ? $trailing_ws + 1 : 0;
122 244         305 my $ord = ord $char;
123 244   33     487 my $escaped_char = $escape_by_ord[$ord] // sprintf( "\\x{%04x}", $ord );
124              
125             # say STDERR "ord=$ord $escaped_char";
126 244         309 $used += length $escaped_char;
127 244         539 push @escaped_chars, $escaped_char;
128             }
129 10         23 while ( $trailing_ws-- ) {
130 10         19 my $ws_char = pop @escaped_chars;
131 10         24 $used -= length $ws_char;
132             }
133 10         23 while ( $used > $max ) {
134 0         0 my $excess_char = pop @escaped_chars;
135 0         0 $used -= length $excess_char;
136 0         0 $truncated = 1;
137             }
138 10         52 return ( join q{}, @escaped_chars ), $truncated;
139             }
140              
141             # Returns a two-line summary of a substring --
142             # a first line with descriptive information and
143             # a one-line escaped version, indented 2 spaces
144             sub Marpa::R3::Internal::substr_as_2lines {
145 10     10 0 26 my ( $what, $p_string, $pos, $length, $max ) = @_;
146 10         26 my ($escaped, $trunc) = substr_as_line( $p_string, $pos, $length, $max );
147 10         18 my ($line_no, $column) = @{line_column( $p_string, $pos)};
  10         25  
148 10         23 my @pieces = ($what);
149 10 50       20 push @pieces, $trunc ? 'begins' : 'is';
150 10         29 push @pieces, qq{at line $line_no, column $column:};
151 10         24 my $line1 = join q{ }, @pieces;
152 10         53 return "$line1\n $escaped";
153             }
154              
155             1;
156              
157             # vim: set expandtab shiftwidth=4: