1 |
package Sack::View; |
2 |
|
3 |
use warnings; |
4 |
use strict; |
5 |
|
6 |
use Data::Dump qw(dump); |
7 |
|
8 |
use lib '/srv/Sack/lib'; |
9 |
use Sack::Color; |
10 |
use Sack; |
11 |
|
12 |
our $coderef; |
13 |
our $out; |
14 |
|
15 |
sub out { $out }; |
16 |
|
17 |
sub code { |
18 |
my ( $self, $code ) = @_; |
19 |
|
20 |
#warn "XX code $code"; |
21 |
|
22 |
undef $out; |
23 |
|
24 |
$coderef = eval "sub { my \$rec = \$_[0]; $code }"; |
25 |
|
26 |
if ( $@ ) { |
27 |
warn "ABORT code: $@"; |
28 |
return; |
29 |
} |
30 |
|
31 |
ref $coderef eq 'CODE'; |
32 |
} |
33 |
|
34 |
sub on_shard { |
35 |
my ( $self, $data ) = @_; |
36 |
|
37 |
die "data not ARRAY but ", ref $data unless ref $data eq 'ARRAY'; |
38 |
|
39 |
#warn "XX data ",dump $data; |
40 |
|
41 |
my $affected = 0; |
42 |
|
43 |
foreach my $pos ( 0 .. $#{ $data } ) { |
44 |
if ( ! defined $data->[$pos] ) { |
45 |
print STDERR "END @ $pos"; |
46 |
last; |
47 |
} |
48 |
|
49 |
my $ok = eval { $coderef->( $data->[$pos] ) }; |
50 |
|
51 |
if ( $@ ) { |
52 |
warn "ABORT at $pos error $@\n"; |
53 |
last; |
54 |
} else { |
55 |
$affected++ if $ok; |
56 |
} |
57 |
|
58 |
# $pos % 10000 == 0 ? print STDERR $pos : |
59 |
$pos % 1000 == 0 ? print STDERR "." : 0 ; |
60 |
}; |
61 |
|
62 |
# warn "## out ", dump( $out ); |
63 |
|
64 |
return $affected; |
65 |
} |
66 |
|
67 |
1; |