File Coverage

blib/lib/Outthentic/DSL/Context/Range.pm
Criterion Covered Total %
statement 3 86 3.4
branch 0 16 0.0
condition 0 23 0.0
subroutine 1 4 25.0
pod 0 3 0.0
total 4 132 3.0


line stmt bran cond sub pod time code
1             package Outthentic::DSL::Context::Range;
2              
3 2     2   7 use strict;
  2         2  
  2         1054  
4              
5             sub new {
6              
7 0     0 0   my $class = shift;
8 0           my $expr = shift;
9              
10 0           my ($a, $b) = split /\s+/, $expr;
11              
12 0           s{\s+}[] for $a, $b;
13              
14 0   0       $a ||= '.*';
15 0   0       $b ||= '.*';
16              
17 0           my $self = bless {}, $class;
18              
19 0           $self->{bound_l} = qr/$a/;
20 0           $self->{bound_r} = qr/$b/;
21              
22 0           $self;
23             }
24              
25             sub change_context {
26              
27 0     0 0   my $self = shift;
28 0           my $cur_ctx = shift; # current search context
29 0           my $orig_ctx = shift; # original search context
30 0           my $succ = shift; # latest succeeded items
31              
32 0           my $bound_l = $self->{bound_l};
33 0           my $bound_r = $self->{bound_r};
34              
35 0           my @new_ctx = (); # new context
36 0           my @chunk;
37              
38 0           my $inside = 0;
39              
40 0   0       $self->{chains} ||= {};
41 0   0       $self->{ranges} ||= []; # this is initial ranges object
42 0   0       $self->{bad_ranges} ||={};
43              
44 0           my $a_index;
45             my $b_index;
46              
47 0           SUCC: for my $c (@{$cur_ctx}){
  0            
48              
49 0 0 0       if ( $inside and $c->[0] =~ $bound_r ){
50              
51              
52 0           push @new_ctx, @chunk;
53            
54 0           push @new_ctx, ["#dsl_note: end range"];
55            
56 0           @chunk = ();
57            
58 0           $inside = 0;
59            
60 0           $b_index = $c->[1];
61            
62 0 0         unless ($self->{chains}->{$a_index}){
63 0           $self->{chains}->{$a_index} = [];
64 0           push @{$self->{ranges}}, [$a_index, $b_index];
  0            
65             }
66            
67 0           for my $j (@chunk) {
68 0           push @new_ctx, $j;
69             }
70            
71 0           @chunk = ();
72            
73 0           next SUCC;
74             }
75              
76 0 0 0       if ($inside){
    0          
77              
78 0           push @chunk, $c;
79              
80             } elsif ( $c->[0] =~ $bound_l and ! defined($self->{bad_ranges}->{$c->[1]})){
81              
82 0           $inside = 1;
83 0           $a_index = $c->[1];
84              
85 0           push @chunk, ["#dsl_note: start range"];
86              
87 0           next SUCC;
88             }
89              
90             }
91              
92 0 0         if ($ENV{OUTH_DBG}){
93 0           for my $c (@new_ctx){
94 0           print "[OTX_DEBUG] @{$c}"
  0            
95             }
96             }
97 0           return [@new_ctx];
98             }
99              
100              
101              
102             sub update_stream {
103              
104 0     0 0   my $self = shift;
105 0           my $cur_ctx = shift; # current search context
106 0           my $orig_ctx = shift; # original search context
107 0           my $succ = shift; # latest succeeded items
108 0           my $stream_ref = shift; # reference to stream object to update
109              
110 0           my %live_ranges;
111            
112 0           my $inside = 0;
113              
114 0   0       $self->{chains} ||= {}; # this is initial chains object
115 0   0       $self->{seen} ||= {};
116              
117              
118 0           for my $c (@{$succ}){
  0            
119              
120 0           for my $r (@{$self->{ranges}}){
  0            
121              
122 0           my $a_index = $r->[0];
123              
124 0           my $b_index = $r->[1];
125              
126 0 0 0       if ($c->[1] > $a_index and $c->[1] < $b_index ){
127 0 0         push @{$self->{chains}->{$a_index}}, $c unless $self->{seen}->{$c->[1]}++;
  0            
128 0           $live_ranges{$a_index} = 1;
129             }
130              
131             }
132              
133             }
134              
135 0           ${$stream_ref} = {};
  0            
136              
137 0           my @k = sort { $b <=> $b } keys %{$self->{chains}};
  0            
  0            
138              
139 0           for my $cid ( @k ) {
140              
141 0 0         if ( exists $live_ranges{$cid} ) {
142 0           ${$stream_ref}->{$cid} = [ sort { $a->[1] <=> $b->[1] } @{$self->{chains}->{$cid}} ];
  0            
  0            
  0            
143             } else {
144 0           delete ${$self->{chains}}{$cid};
  0            
145 0           $self->{bad_ranges}->{$cid} = 1;
146             }
147              
148             }
149              
150             }
151              
152             1;
153