File Coverage

blib/lib/Outthentic/DSL.pm
Criterion Covered Total %
statement 146 385 37.9
branch 36 200 18.0
condition 10 31 32.2
subroutine 24 33 72.7
pod 3 19 15.7
total 219 668 32.7


line stmt bran cond sub pod time code
1             package Outthentic::DSL;
2              
3 2     2   26478 use strict;
  2         3  
  2         66  
4              
5             our $VERSION = '0.2.8';
6              
7 2     2   7 use Carp;
  2         3  
  2         123  
8 2     2   1058 use Data::Dumper;
  2         12898  
  2         96  
9 2     2   679 use Outthentic::DSL::Context::Range;
  2         2  
  2         51  
10 2     2   701 use Outthentic::DSL::Context::Default;
  2         3  
  2         52  
11 2     2   697 use Outthentic::DSL::Context::TextBlock;
  2         3  
  2         73  
12 2     2   1328 use File::Temp qw/ tempfile /;
  2         28980  
  2         103  
13 2     2   1239 use JSON;
  2         16232  
  2         6  
14              
15             $Data::Dumper::Terse=1;
16              
17             sub results {
18              
19 1     1 1 1 my $self = shift;
20              
21 1         2 $self->{results};
22             }
23              
24             sub add_result {
25              
26 1     1 0 1 my $self = shift;
27 1         1 my $item = shift;
28              
29 1         1 push @{$self->results}, { %{$item}, type => 'check_expression' };
  1         3  
  1         4  
30            
31             }
32              
33             sub debug {
34              
35 0     0 0 0 my $self = shift;
36 0         0 my $item = shift;
37              
38 0         0 push @{$self->results}, { message => $item , type => 'debug' };
  0         0  
39            
40             }
41              
42              
43             sub new {
44              
45 2     2 1 352 my $class = shift;
46 2         5 my $output = shift;
47 2   50     12 my $opts = shift || {};
48              
49             bless {
50             results => [],
51             original_context => [],
52             current_context => [],
53             context_modificator => Outthentic::DSL::Context::Default->new(),
54             has_context => 0,
55             succeeded => [],
56             captures => [],
57             within_mode => 0,
58             block_mode => 0,
59             last_match_line => undef,
60             last_check_status => undef,
61             debug_mod => 0,
62             output => $output||'',
63             match_l => 40,
64             stream => {},
65             languages => {},
66 2   50     18 %{$opts},
  2         38  
67             }, __PACKAGE__;
68              
69             }
70              
71             sub create_context {
72              
73 1     1 0 2 my $self = shift;
74              
75 1 50       2 return if $self->{has_context};
76              
77 1         2 my $i = 0;
78              
79 1         1 my @original_context = ();
80              
81 1         5 for my $l ( split /\n/, $self->{output} ){
82 1         1 chomp $l;
83 1         1 $i++;
84 1 50       4 $l=":blank_line" unless $l=~/\S/;
85 1         2 push @original_context, [$l, $i];
86              
87 1 50       4 $self->debug("[oc] [$l, $i]") if $self->{debug_mod} >= 2;
88              
89             }
90              
91 1         2 $self->{original_context} = [@original_context];
92              
93 1         1 $self->{current_context} = [@original_context];
94              
95 1 50       3 $self->debug('context populated') if $self->{debug_mod} >= 2;
96              
97              
98 1         2 $self->{has_context} = 1;
99              
100              
101             }
102              
103              
104             sub reset_context {
105              
106 0     0 0 0 my $self = shift;
107              
108 0         0 $self->{current_context} = $self->{original_context};
109              
110 0 0       0 $self->debug('reset search context') if $self->{debug_mod} >= 2;
111              
112 0         0 $self->{context_modificator} = Outthentic::DSL::Context::Default->new();
113              
114             }
115              
116             sub reset_captures {
117              
118 1     1 0 2 my $self = shift;
119 1         1 $self->{captures} = [];
120 1 50       51 unlink $self->{cache_dir}."/captures.json" if -f $self->{cache_dir}."/captures.json";
121             }
122              
123             sub reset_succeeded {
124              
125 1     1 0 2 my $self = shift;
126 1         2 $self->{succeeded} = [];
127              
128             }
129              
130              
131             sub stream {
132              
133 0     0 0 0 my $self = shift;
134 0         0 my @stream;
135 0         0 my $i=0;
136              
137 0         0 for my $cid ( sort { $a <=> $b } keys %{$self->{stream}} ){
  0         0  
  0         0  
138 0         0 $stream[$i]=[];
139 0         0 for my $c (@{$self->{stream}->{$cid}}){
  0         0  
140 0         0 push @{$stream[$i]}, $c->[0];
  0         0  
141 0 0       0 $self->debug("[stream {$cid}] $c->[0]") if $self->{debug_mod} >= 2;
142             }
143 0         0 $i++;
144             }
145 0         0 [@stream]
146             }
147              
148             sub match_lines {
149              
150 0     0 0 0 my $self = shift;
151 0         0 return $self->{succeeded};
152             }
153              
154              
155             sub check_line {
156              
157 1     1 0 1 my $self = shift;
158 1         2 my $pattern = shift;
159 1         1 my $check_type = shift;
160 1         2 my $message = shift;
161              
162 1         1 my $status = 0;
163              
164 1         6 s/\s+$// for $pattern;
165              
166 1         3 $self->reset_captures;
167              
168 1         1 my @captures = ();
169              
170 1         2 $self->create_context;
171              
172 1 50       3 $self->debug("[lookup] $pattern ...") if $self->{debug_mod} >= 2;
173              
174 1         1 my @original_context = @{$self->{original_context}};
  1         3  
175 1         2 my @context_new = ();
176              
177             # dynamic context
178             my $dc = $self->{context_modificator}->change_context(
179             $self->{current_context},
180             $self->{original_context},
181             $self->{succeeded}
182 1         5 );
183              
184             $self->debug("context modificator applied: ".(ref $self->{context_modificator}))
185 1 50       7 if $self->{debug_mod} >=2;
186            
187 1 50       3 if ( $self->{debug_mod} >= 2 ) {
188 0         0 for my $dcl (@$dc){
189 0         0 $self->debug("[dc] $dcl->[0]");
190             }
191              
192             };
193            
194              
195 1         2 $self->reset_succeeded;
196              
197 1 50       3 if ($check_type eq 'default'){
    0          
198 1         1 for my $c (@{$dc}){
  1         2  
199              
200 1         1 my $ln = $c->[0];
201              
202 1 50       3 next if $ln =~/#dsl_note:/; # skip debug entries
203              
204 1 50       4 if ( index($ln,$pattern) != -1){
205 0         0 $status = 1;
206 0         0 $self->{last_match_line} = $ln;
207 0         0 push @{$self->{succeeded}}, $c;
  0         0  
208             }
209             }
210              
211             }elsif($check_type eq 'regexp'){
212              
213              
214 0         0 for my $c (@{$dc}) {
  0         0  
215              
216 0         0 my $re = qr/$pattern/;
217              
218 0         0 my $ln = $c->[0];
219              
220 0 0       0 next if $ln eq ":blank_line";
221 0 0       0 next if $ln =~/#dsl_note:/;
222              
223 0         0 my @foo = ($ln =~ /$re/g);
224              
225 0 0       0 if (scalar @foo){
226 0         0 push @captures, [@foo];
227 0         0 $status = 1;
228 0         0 push @{$self->{succeeded}}, $c;
  0         0  
229 0 0       0 push @context_new, $c if $self->{within_mode};
230 0         0 $self->{last_match_line} = $ln;
231             }
232              
233             }
234             }else {
235 0         0 confess "unknown check_type: $check_type";
236             }
237              
238              
239              
240 1         2 $self->{last_check_status} = $status;
241              
242 1 50       3 if ( $self->{debug_mod} >= 2 ){
243              
244 0         0 my $i = 1;
245 0         0 my $j = 1;
246 0         0 for my $cpp (@captures){
247 0         0 for my $cp (@{$cpp}){
  0         0  
248 0         0 $self->debug("CAP[$i,$j]: $cp");
249 0         0 $j++;
250             }
251 0         0 $i++;
252 0         0 $j=1;
253             }
254              
255 0         0 for my $s (@{$self->{succeeded}}){
  0         0  
256 0         0 $self->debug("SUCC: $s->[0]");
257             }
258             }
259              
260 1         2 $self->{captures} = [ @captures ];
261              
262 1 50       2 if ($self->{cache_dir}){
263             open CAPTURES, '>', $self->{cache_dir}.'/captures.json'
264 0 0       0 or confess "can't open ".($self->{cache_dir})."captures.json to write $!";
265 0         0 print CAPTURES encode_json($self->{captures});
266             $self->debug("CAPTURES saved at ".$self->{cache_dir}.'/captures.json')
267 0 0       0 if $self->{debug_mod} >= 1;
268 0         0 close CAPTURES;
269             }
270              
271             # update context
272 1 50 33     7 if ( $self->{within_mode} and $status ){
    50 33        
273 0         0 $self->{current_context} = [@context_new];
274             $self->debug("[WITH] within mode: modify search context to: $context_new[0][0]")
275 0 0       0 if $self->{debug_mod} >= 2
276             }elsif ( $self->{within_mode} and ! $status ){
277 0         0 $self->{current_context} = []; # empty context if within expression has not passed
278 0 0       0 $self->debug('within mode: modify search context to: '.(Dumper([@context_new]))) if $self->{debug_mod} >= 2
279             }
280              
281 1         6 $self->add_result({ status => $status , message => $message });
282              
283              
284             $self->{context_modificator}->update_stream(
285             $self->{current_context},
286             $self->{original_context},
287             $self->{succeeded},
288 1         6 \($self->{stream}),
289             );
290              
291 1         1 return $status;
292              
293             }
294              
295             sub validate {
296              
297 1     1 1 5 my $self = shift;
298 1         2 my $check_list = shift;
299              
300 1         1 my $block_type;
301             my @multiline_block;
302 1         2 my $here_str_mode = 0;
303 1         1 my $here_str_marker;
304              
305             my @lines;
306 1 50       26 if ( -f $check_list ){
307 0 0       0 open my $ff, $check_list or die "can't open file check_list to read: $!";
308 0         0 while (my $ii = <$ff>){
309 0         0 push @lines, $ii;
310             }
311 0         0 close $ff;
312             } else {
313 1 50       6 @lines = ( ref $check_list ) ? @{$check_list} : ( split "\n", $check_list );
  0         0  
314             }
315              
316 1         2 LINE: for my $l ( @lines ) {
317              
318 1         2 chomp $l;
319              
320 1 50       8 $self->debug("[dsl::$block_type] $l") if $self->{debug_mod} >= 2;
321              
322 1 50       5 next LINE unless $l =~ /\S/; # skip blank lines
323              
324 1 50       3 next LINE if $l=~ /^\s*#(.*)/; # skip comments
325            
326 1 50 33     4 if ($here_str_mode && $l=~s/^$here_str_marker\s*$//) {
327              
328 0         0 $here_str_mode = 0;
329              
330 0 0       0 $self->debug("here string mode off") if $self->{debug_mod} >= 2;
331              
332 0 0       0 $self->debug("flushing $block_type block") if $self->{debug_mod} >= 2;
333              
334 2     2   2438 no strict 'refs';
  2         4  
  2         125  
335              
336 0         0 my $name = "handle_";
337              
338 0         0 $name.=$block_type;
339              
340 0         0 &$name($self, [ @multiline_block ] );
341              
342 0         0 undef @multiline_block; undef $block_type;
  0         0  
343              
344 0         0 next LINE;
345              
346             }
347              
348 1 0 33     3 if ( $block_type and $l!~/\\\s*$/ and ! $here_str_mode ){
      33        
349              
350 2     2   18 no strict 'refs';
  2         2  
  2         198  
351              
352 0         0 my $name = "handle_";
353              
354 0         0 $name.=$block_type;
355              
356 0 0       0 $self->debug("flushing $block_type block") if $self->{debug_mod} >= 2;
357              
358 0         0 &$name($self, [ @multiline_block ] );
359              
360 0         0 undef @multiline_block; undef $block_type;
  0         0  
361              
362              
363             }
364              
365 1 0 33     4 if ( $block_type and $l=~/^\s*(code|generator|validator):\s*(.*)/ and ! $here_str_mode ){
      33        
366              
367 2     2   8 no strict 'refs';
  2         2  
  2         940  
368              
369 0         0 my $name = "handle_";
370              
371 0         0 $name.=$block_type;
372              
373 0 0       0 $self->debug("flushing $block_type block") if $self->{debug_mod} >= 2;
374              
375 0         0 &$name($self, [ @multiline_block ] );
376              
377 0         0 undef @multiline_block; undef $block_type;
  0         0  
378              
379              
380             }
381              
382 1 0 0     4 if ( $block_type && ( $l=~s/\\\s*$// or $here_str_mode )) { # multiline block
      33        
383              
384             # this is multiline block or here string,
385             # accumulate lines until meet line not ending with '\' ( for multiline blocks )
386             # or here string end marker ( for here stings )
387              
388 0         0 push @multiline_block, $l;
389              
390 0         0 next LINE;
391              
392             }
393              
394              
395              
396 1 50       15 if ( $l=~/^\s*begin:\s*$/) { # begining of the text block
    50          
    50          
    50          
    50          
    50          
    50          
    50          
397              
398 0 0       0 do { undef @multiline_block; undef $block_type } if $block_type;
  0         0  
  0         0  
399              
400 0 0       0 die "you can't switch to text block mode when within mode is enabled" if $self->{within_mode};
401              
402 0         0 $self->{context_modificator} = Outthentic::DSL::Context::TextBlock->new();
403              
404 0 0       0 $self->debug('text block start') if $self->{debug_mod} >= 2;
405              
406 0         0 $self->{block_mode} = 1;
407              
408 0         0 $self->reset_succeeded();
409              
410             } elsif ($l=~/^\s*end:\s*$/) { # end of the text block
411              
412 0         0 $self->{block_mode} = 0;
413              
414 0         0 $self->reset_context();
415              
416 0 0       0 $self->debug('text block end') if $self->{debug_mod} >= 2;
417              
418             } elsif ($l=~/^\s*reset_context:\s*$/) {
419              
420 0 0       0 do { undef @multiline_block; undef $block_type } if $block_type;
  0         0  
  0         0  
421 0         0 $self->reset_context();
422              
423             } elsif ($l=~/^\s*assert:\s+(\d+)\s+(.*)/) {
424              
425 0         0 my $status = $1; my $message = $2;
  0         0  
426              
427 0 0       0 do { undef @multiline_block; undef $block_type } if $block_type;
  0         0  
  0         0  
428              
429 0 0       0 $self->debug("assert found: $status | $message") if $self->{debug_mod} >= 2;
430              
431 0 0       0 $status = 0 if $status eq 'false'; # ruby to perl5 conversion
432              
433 0 0       0 $status = 1 if $status eq 'true'; # ruby to perl5 conversion
434              
435 0         0 $self->add_result({ status => $status , message => $message });
436              
437             } elsif ($l=~/^\s*between:\s+(.*)/) { # range context
438              
439              
440 0 0       0 die "you can't switch to range context mode when within mode is enabled" if $self->{within_mode};
441 0 0       0 die "you can't switch to range context mode when block mode is enabled" if $self->{block_mode};
442              
443 0         0 my $pattern = $1;
444              
445 0 0       0 do { undef @multiline_block; undef $block_type } if $block_type;
  0         0  
  0         0  
446              
447 0         0 $self->{context_modificator} = Outthentic::DSL::Context::Range->new($1);
448              
449              
450             } elsif ($l=~/^\s*(code|generator|validator):\s*(.*)/) {
451              
452 0         0 my $my_block_type = $1;
453              
454 0         0 my $code = $2;
455              
456 0 0       0 if ( $code=~s/(.*)\\\s*$// ) {
    0          
457              
458             # this is multiline block, accumulate lines until meet '\' line
459 0         0 $block_type = $my_block_type;
460 0         0 my $first_line = $1;
461 0         0 push @multiline_block, $first_line;
462              
463 0 0       0 $self->debug("starting $block_type block") if $self->{debug_mod} >= 2;
464 0 0       0 $self->debug("first line in block: <<<$first_line>>>") if $self->{debug_mod} >= 2;
465              
466             } elsif ( $code=~s/<<(\S+)// ) {
467              
468 0         0 $block_type = $my_block_type;
469              
470 0         0 $here_str_mode = 1;
471              
472 0         0 $here_str_marker = $1;
473              
474 0 0       0 $self->debug("$block_type block start. heredoc marker: $here_str_marker") if $self->{debug_mod} >= 2;
475              
476              
477             } else {
478              
479 0 0       0 $self->debug("one-line $my_block_type found: $code") if $self->{debug_mod} >= 2;
480              
481 2     2   9 no strict 'refs';
  2         2  
  2         399  
482              
483 0         0 my $name = "handle_";
484              
485 0         0 $name.=$my_block_type;
486              
487 0 0       0 $self->debug("flushing one-line $block_type block") if $self->{debug_mod} >= 2;
488              
489 0         0 &$name($self,$code);
490              
491              
492             }
493              
494             } elsif ($l=~/^\s*regexp:\s*(.*)/) { # `regexp' line
495              
496 0         0 my $re = $1;
497              
498 0         0 $re=~s/\s+#.*//;
499              
500 0         0 $re=~s/^\s+//;
501              
502 0         0 $self->handle_regexp($re);
503              
504             } elsif ($l=~/^\s*within:\s*(.*)/) {
505              
506 0 0       0 die "you can't switch to within mode when text block mode is enabled" if $self->{block_mode};
507              
508 0         0 my $re = $1;
509              
510 0         0 $re=~s/\s+#.*//;
511              
512 0         0 $re=~s/^\s+//;
513              
514 0         0 $self->handle_within($re);
515              
516             } else { # `plain string' line
517              
518 1         3 $l=~s/\s+#.*//;
519              
520 1         2 $l=~s/^\s+//;
521              
522 1         3 $self->handle_plain($l);
523              
524             }
525             }
526              
527 1 50       39 if ( $block_type ){
528              
529 2     2   6 no strict 'refs';
  2         2  
  2         2166  
530              
531 0         0 my $name = "handle_";
532              
533 0 0       0 $self->debug("flushing $block_type block") if $self->{debug_mod} >= 2;
534              
535 0         0 $name.=$block_type;
536              
537 0         0 &$name($self, [ @multiline_block ] );
538              
539 0         0 undef @multiline_block; undef $block_type;
  0         0  
540              
541              
542             }
543              
544             }
545              
546              
547             sub handle_code {
548              
549 0     0 0 0 my $self = shift;
550 0         0 my $code = shift;
551 0         0 my $results;
552              
553 0 0       0 if (! ref $code) {
554              
555 0         0 $results = eval "package main; $code;";
556 0 0       0 confess "eval error; sub:handle_code; code:$code\nerror: $@" if $@;
557 0 0       0 $self->debug("code OK. single line. code: $code") if $self->{debug_mod} >= 3;
558              
559             } else {
560              
561 0         0 my $i = 0;
562              
563 0         0 my $code_to_print = join "\n", map { my $v=$_; $i++; "[$i] $v" } @$code;
  0         0  
  0         0  
  0         0  
564              
565 0 0       0 if ($code->[0]=~s/^\!(.*)//) {
566              
567 0         0 my $ext_runner = $1;
568              
569 0         0 my $language = (split /\\/, $ext_runner)[-1];
570              
571 0 0       0 if ($language eq 'perl') {
572              
573 0         0 shift @$code;
574 0         0 my $code_to_eval = join "\n", @$code;
575 0         0 $results = eval "package main; $code_to_eval";
576 0 0       0 confess "eval error; sub:handle_code; code:\n$code_to_print\nerror: $@" if $@;
577 0 0       0 $self->debug("code OK. inline(perl). $code_to_eval") if $self->{debug_mod} >= 3;
578              
579             } else {
580              
581 0         0 my $source_file = File::Temp->new( DIR => $self->{cache_dir} , UNLINK => 0 );
582              
583 0         0 shift @$code;
584              
585 0         0 my $code_to_eval = join "\n", @$code;
586              
587 0 0       0 open SOURCE_CODE, '>', $source_file or die "can't open source code file $source_file to write: $!";
588              
589 0         0 print SOURCE_CODE $code_to_eval;
590              
591 0         0 close SOURCE_CODE;
592              
593 0 0       0 if ($language eq 'bash'){
594              
595 0 0       0 if ($self->{languages}->{$language}){
596 0         0 $ext_runner = "bash -c '".($self->{languages}->{$language})." && source $source_file'";
597             }else{
598 0         0 $ext_runner = "bash -c 'source $source_file'";
599             }
600              
601             } else {
602 0 0       0 $ext_runner = $self->{languages}->{$language} if $self->{languages}->{$language};
603 0         0 $ext_runner.=' '.$source_file;
604             }
605              
606              
607 0         0 my $st = system("$ext_runner 2>$source_file.err 1>$source_file.out");
608              
609 0 0       0 if ($st != 0){
610 0         0 confess "$ext_runner failed, see $source_file.err for detailes";
611             }
612              
613 0 0       0 $self->debug("code OK. inline. $ext_runner") if $self->{debug_mod} >= 2;
614              
615 0 0       0 open EXT_OUT, "$source_file.out" or die "can't open file $source_file.out to read: $!";
616 0         0 $results = join "", ;
617 0         0 close EXT_OUT;
618              
619 0 0       0 unless ($ENV{OTX_KEEP_SOURCE_FILES}) {
620 0         0 unlink("$source_file.out");
621 0         0 unlink("$source_file.err");
622 0         0 unlink("$source_file");
623             }
624             }
625              
626              
627              
628             } else {
629              
630 0         0 my $code_to_eval = join "\n", @$code;
631 0         0 $results = eval "package main; $code_to_eval";
632 0 0       0 confess "eval error; sub:handle_code; code:\n$code_to_print\nerror: $@" if $@;
633 0 0       0 $self->debug("code OK. multiline. $code_to_eval") if $self->{debug_mod} >= 3;
634              
635             }
636              
637              
638             }
639              
640 0         0 return $results;
641              
642             }
643              
644             sub handle_validator {
645              
646 0     0 0 0 my $self = shift;
647 0         0 my $code = shift;
648 0         0 my $r = $self->handle_code($code);
649 0         0 $self->add_result({ status => $r->[0] , message => $r->[1] });
650              
651             }
652              
653             sub handle_generator {
654              
655 0     0 0 0 my $self = shift;
656 0         0 my $code = shift;
657              
658 0         0 $self->validate(
659             $self->handle_code($code)
660             )
661              
662             }
663              
664             sub handle_simple {
665              
666 1     1 0 2 my $self = shift;
667 1         1 my $pattern = shift;
668 1         2 my $check_type = shift;
669              
670 1         1 my $msg;
671              
672 1         2 my $lshort = $self->_short_string($pattern);
673              
674 1         2 my $reset_context = 0;
675              
676 1 50       3 if ($self->{within_mode}) {
677              
678 0         0 $self->{within_mode} = 0;
679              
680 0         0 $reset_context = 1;
681              
682 0 0       0 if ($self->{last_check_status}){
683 0 0       0 if ($check_type eq 'regexp'){
684 0         0 $msg = "'".($self->_short_string($self->{last_match_line}))."' match /$lshort/"
685             } else {
686 0         0 $msg = "'".($self->_short_string($self->{last_match_line}))."' has '".$lshort."'"
687             }
688             } else {
689 0 0       0 if ($check_type eq 'regexp'){
690 0         0 $msg = "text match /$lshort/"
691             } else {
692 0         0 $msg = "text has '".$lshort."'"
693             }
694             }
695              
696              
697             } else {
698              
699 1 50       2 if ($self->{block_mode}){
700 0 0       0 if ($check_type eq 'regexp'){
701 0         0 $msg = "[b] text match /$lshort/";
702             } else {
703 0         0 $msg = "[b] text has '".$lshort."'";
704             }
705             } else {
706 1 50       4 if ($check_type eq 'regexp'){
707 0         0 $msg = "text match /$lshort/";
708             } else {
709 1         3 $msg = "text has '".$lshort."'";
710             }
711             }
712             }
713              
714              
715 1         3 $self->check_line($pattern,$check_type, $msg);
716              
717 1 50       2 $self->reset_context if $reset_context;
718              
719 1 50       5 $self->debug("$check_type check DONE. >>> <<<$pattern>>>") if $self->{debug_mode} >= 3;
720              
721             }
722              
723             sub handle_regexp {
724              
725 0     0 0 0 my $self = shift;
726 0         0 my $re = shift;
727            
728 0         0 $self->handle_simple($re, 'regexp');
729              
730             }
731              
732             sub handle_within {
733              
734 0     0 0 0 my $self = shift;
735 0         0 my $pattern = shift;
736              
737 0         0 my $msg;
738              
739 0 0       0 if ($self->{within_mode}) {
740 0 0       0 if ($self->{last_check_status}){
741 0         0 $msg = "'".($self->_short_string($self->{last_match_line}))."' match /$pattern/"
742             } else {
743 0         0 $msg = "text match /$pattern/"
744             }
745              
746             }else{
747 0         0 $msg = "text match /$pattern/";
748             }
749              
750 0         0 $self->{within_mode} = 1;
751              
752 0         0 $self->check_line($pattern,'regexp', $msg);
753              
754 0 0       0 $self->debug("within check DONE. >>> <<<$pattern>>>") if $self->{debug_mode} >= 3;
755            
756             }
757              
758             sub handle_plain {
759              
760 1     1 0 1 my $self = shift;
761 1         1 my $l = shift;
762              
763 1         5 $self->handle_simple($l, 'default');
764              
765             }
766              
767              
768             sub _short_string {
769              
770 1     1   1 my $self = shift;
771 1         2 my $str = shift;
772 1         2 my $sstr = substr( $str, 0, $self->{match_l} );
773              
774 1         4 s{\r}[]g for $str;
775 1         2 s{\r}[]g for $sstr;
776              
777 1         4 s/\s+$// for $sstr;
778 1         2 s/\s+$// for $str;
779            
780 1 50       7 return $sstr < $str ? "$sstr ..." : $sstr;
781              
782             }
783              
784             1;
785              
786             __END__