File Coverage

blib/lib/Language/FormulaEngine/Parser/ContextUtil.pm
Criterion Covered Total %
statement 22 50 44.0
branch 2 16 12.5
condition 3 25 12.0
subroutine 5 6 83.3
pod 3 3 100.0
total 35 100 35.0


line stmt bran cond sub pod time code
1             package Language::FormulaEngine::Parser::ContextUtil;
2 9     9   64 use strict;
  9         21  
  9         266  
3 9     9   49 use warnings;
  9         38  
  9         230  
4 9     9   47 use Exporter 'import';
  9         30  
  9         6189  
5             our @EXPORT_OK= qw( calc_text_coordinates format_context_string format_context_multiline );
6              
7             # ABSTRACT: utility methods for parsers
8             our $VERSION = '0.08'; # VERSION
9              
10              
11             sub calc_text_coordinates {
12 2     2 1 7 my ($buf, $pos, $line, $col)= @_;
13 2   50     13 $line ||= 0;
14 2   50     9 $col ||= 0;
15             # If there are any newlines from the start of the buffer to the given position...
16 2         6 my $line_end= rindex($buf, "\n", $pos-1);
17 2 50       6 if ($line_end >= 0) {
18             # ...then add up the number of newlines and re-calculate the column
19 0         0 $line+= (substr($buf, 0, $line_end+1) =~ /\n/);
20 0         0 $col= $pos - ($line_end+1);
21             }
22             else {
23 2         6 $col += $pos;
24             }
25 2         5 return ($line, $col);
26             }
27              
28              
29             sub format_context_string {
30 2     2 1 8 my ($buf, $start, $limit, $line, $col)= @_;
31             # If we don't have a buffer, there's nothing to show, so print "end of input".
32 2 50 33     25 defined $buf and length $buf > $start
33             or return '(end of input)';
34 2         9 my $context= substr($buf, $start, 20);
35 2         6 $context =~ s/\n.*//s; # remove subsequent lines
36 2         8 ($line, $col)= calc_text_coordinates($buf, $start, $line, $col);
37 2         32 return sprintf '"%s" at line %d char %d', $context, $line+1, $col+1;
38             }
39              
40              
41             sub format_context_multiline {
42 0     0 1   my ($self, $buf, $start, $limit, %args)= @_;
43 0           my ($prefix, $token, $suffix)= ('','','');
44 0   0       my $line= $args{buffer_line} || 0;
45 0   0       my $col= $args{buffer_col} || 0;
46 0   0       my $max_width= $args{max_width} || 78;
47 0   0       my $min_token= $args{min_token} || 30;
48            
49             # Make sure both start and limit are defined, defaulting to equal
50 0   0       $start ||= $limit || 0;
      0        
51 0   0       $limit ||= $start;
52             # If they are identical, move limit over one
53 0 0         $limit++ if $start == $limit;
54             # If we don't have a buffer, there's nothing to show, so print "end of input".
55 0 0         if (!length($buf)) {
56 0           $suffix= '(end of input)';
57             }
58             else {
59 0           $prefix= substr($buf, 0, $start);
60 0           $token= substr($buf, $start, $limit-$start);
61 0           $suffix= substr($buf, $limit);
62             }
63            
64             # Truncate prefix and suffix at line breaks
65 0           $prefix =~ s/.*\n//s;
66 0           $suffix =~ s/\n.*//s;
67             # Limit lengths of prefix and suffix and token
68 0 0         if (length($prefix) + length($token) > $max_width) {
69 0           $min_token= min(length($token), $min_token);
70             # truncate prefix, or token, or both
71 0 0         if (length($prefix) > $max_width - $min_token) {
72 0           substr($prefix, 0, -($max_width - $min_token))= '';
73             }
74 0 0         if (length($prefix) + length($token) > $max_width) {
75 0           substr($token, -($max_width - length($prefix) - length($token)))= '';
76             }
77             }
78 0 0         if (length($prefix) + length($token) + length($suffix) > $max_width) {
79 0           substr($suffix, -($max_width - length($prefix) - length($token)))= '';
80             }
81 0           ($line, $col)= calc_text_coordinates($buf, $start, $line, $col);
82 0   0       return sprintf "%s%s%s\n%s%s\n (line %d char %d)\n",
83             $prefix, $token, $suffix,
84             ' ' x length($prefix), '^' x (length($token) || 1),
85             $line+1, $col+1;
86             }
87              
88             1;
89              
90             __END__
91              
92             =pod
93              
94             =encoding UTF-8
95              
96             =head1 NAME
97              
98             Language::FormulaEngine::Parser::ContextUtil - utility methods for parsers
99              
100             =head1 VERSION
101              
102             version 0.08
103              
104             =head1 EXPORTED FUNCTIONS
105              
106             =head2 calc_text_coordinates
107              
108             my ($line, $col)= calc_text_coordinates( $buffer, $pos );
109             my ($line, $col)= calc_text_coordinates( $buffer, $pos, $buffer_line, $buffer_col );
110              
111             Returns the 0-based line number and character number of an offset within
112             a buffer. The line/column of the start of the buffer can be given as
113             additional arguments.
114              
115             =head2 format_context_string
116              
117             my $message= format_context_string( $buffer, $token_start, $token_limit, $buffer_line, $buffer_col );
118             # "'blah blah' on line 15, char 12"
119              
120             Returns a single-string view of where the token occurs in the buffer.
121             This is useful for single-line "die" messages.
122              
123             =head2 format_context_multiline
124              
125             my $tty_text= format_context_multiline( $buffer, $token_start, $token_limit, \%args );
126            
127             # "blah blah blah token blah blah\n"
128             # ." ^^^^^\n"
129             # ." (line 15, char 16)\n";
130              
131             More advanced view of the input string, printed on three lines with the second
132             marking the token within its context and third listing the line/column.
133             This is only useful with a fixed-width font in a multi-line context.
134              
135             This method also supports various options for formatting.
136              
137             =head1 AUTHOR
138              
139             Michael Conrad <mconrad@intellitree.com>
140              
141             =head1 COPYRIGHT AND LICENSE
142              
143             This software is copyright (c) 2023 by Michael Conrad, IntelliTree Solutions llc.
144              
145             This is free software; you can redistribute it and/or modify it under
146             the same terms as the Perl 5 programming language system itself.
147              
148             =cut