File Coverage

blib/lib/Outthentic/DSL/Context/TextBlock.pm
Criterion Covered Total %
statement 6 65 9.2
branch 0 36 0.0
condition n/a
subroutine 2 5 40.0
pod 0 3 0.0
total 8 109 7.3


line stmt bran cond sub pod time code
1             package Outthentic::DSL::Context::TextBlock;
2 2     2   14 use Data::Dumper;
  2         5  
  2         414  
3              
4              
5             sub new {
6              
7 0     0 0   bless { succeeded => [] }, __PACKAGE__
8             }
9              
10             sub change_context {
11              
12 0     0 0   my $self = shift;
13 0           my $cur_ctx = shift; # current search context
14 0           my $orig_ctx = shift; # original search context
15 0           my $succ = shift; # latest succeeded items
16              
17             #warn Dumper($cur_ctx);
18             #warn Dumper($succ);
19              
20 0           my $new_ctx = []; # new context
21              
22 0 0         if (scalar @{$succ}){
  0            
23              
24 0           for my $c (@{$succ}){
  0            
25 0 0         push @$new_ctx, $orig_ctx->[$c->[1]] if defined($orig_ctx->[$c->[1]]);
26             }
27             }else{
28 0           $new_ctx = $cur_ctx;
29             }
30              
31 0           $new_ctx;
32              
33             }
34              
35              
36             sub update_stream {
37              
38 0 0   0 0   print "\n\nxxxx start of text block update stream \n \n \n" if $ENV{OUTH_DBG};
39              
40 0           my $self = shift;
41 0           my $cur_ctx = shift; # current search context
42 0           my $orig_ctx = shift; # original search context
43 0           my $succ = shift; # latest succeeded items
44 0           my $stream_ref = shift; # reference to stream object to update
45              
46 2     2   14 use Data::Dumper;
  2         4  
  2         1111  
47              
48 0           my %live_chains = ();
49              
50              
51 0 0         if (scalar @{$succ}) {
  0            
52              
53 0 0         unless ($self->{chains}){ # chain initialization
54 0           for my $c ( @{$succ} ){
  0            
55 0 0         print "[OTX_DEBUG] init chain $c[0]($c[1]) )...\n" if $ENV{OUTH_DBG};
56 0           $self->{chains}->{$c->[1]} = [$c];
57             }
58             };
59              
60              
61              
62 0           for my $c (@{$succ}){
  0            
63 0           my @k = keys %{$self->{chains}};
  0            
64 0           CHAIN: for my $cid (sort { $a <=> $b } @k ){
  0            
65              
66 0 0         next CHAIN if $live_chains{$cid};
67              
68 0 0         print "[OTX_DEBUG] chain end at ".($self->{chains}->{$cid}->[-1]->[1])."\n" if $ENV{OUTH_DBG};
69            
70 0 0         if ( $self->{chains}->{$cid}->[-1]->[1] == $c->[1]-1 ){
    0          
71 0           $live_chains{$cid} = 1;
72 0           push @{$self->{chains}->{$cid}}, $c;
  0            
73 0 0         print "[OTX_DEBUG] push $c->[0]($c->[1]) to chain $cid ...\n" if $ENV{OUTH_DBG};
74 0 0         print "[OTX_DEBUG] new chain end at ".($self->{chains}->{$cid}->[-1]->[0])."\n" if $ENV{OUTH_DBG};
75 0           last CHAIN;
76             }elsif ( $self->{chains}->{$cid}->[-1]->[1] == $c->[1] ) {
77 0           $live_chains{$cid} = 1;
78 0 0         print "[OTX_DEBUG] keep chain $cid ...\n" if $ENV{OUTH_DBG};
79 0           last CHAIN;
80             }else{
81 0 0         print "[OTX_DEBUG] skip $c->[0] [ $c->[1] ] ...\n" if $ENV{OUTH_DBG};
82             }
83             }
84             }
85             }
86              
87             #warn Dumper([sort { $a <=> $b } keys %live_chains]) if $ENV{OUTH_DBG};
88              
89             # delete failed chains
90              
91 0           ${$stream_ref} = {};
  0            
92              
93 0 0         print "\n\nxxxx generating text block stream xxxx \n \n \n" if $ENV{OUTH_DBG};
94              
95 0           for my $cid (sort { $a <=> $b } keys %{$self->{chains}}){
  0            
  0            
96 0 0         if ($live_chains{$cid}) {
97 0           ${$stream_ref}->{$cid} = $self->{chains}->{$cid};
  0            
98 0 0         print "[OTX_DEBUG] chain end at ".($self->{chains}->{$cid}->[-1]->[1])."\n" if $ENV{OUTH_DBG};
99             } else {
100 0           delete @{$self->{chains}}{$cid};
  0            
101             }
102             }
103              
104 0 0         print "\n\nxxxx end of text block update stream \n \n \n" if $ENV{OUTH_DBG};
105              
106             }
107              
108              
109             1;
110