lib/Sack/View.pm

package Sack::View;

use warnings;
use strict;

use Data::Dump qw(dump);

use lib '/srv/Sack/lib';
use Sack::Color;
use Sack;

our $coderef;
our $out;

sub out { $out };

sub code {
        my ( $self, $code ) = @_;

#warn "XX code $code";

        undef $out;

        $coderef = eval "sub { my \$rec = \$_[0]; $code }";

        if ( $@ ) {
                warn "ABORT code: $@";
                return;
        }

        ref $coderef eq 'CODE';
}

sub on_shard {
        my ( $self, $data ) = @_;

        die "data not ARRAY but ", ref $data unless ref $data eq 'ARRAY';

#warn "XX data ",dump $data;

        my $affected = 0;

        foreach my $pos ( 0 .. $#{ $data } ) {
                if ( ! defined $data->[$pos] ) {
                        print STDERR "END @ $pos";
                        last;
                }

                my $ok = eval { $coderef->( $data->[$pos] ) };

                if ( $@ ) {
                        warn "ABORT at $pos error $@\n";
                        last;
                } else {
                        $affected++ if $ok;
                }

#               $pos % 10000 == 0 ? print STDERR $pos :
                $pos % 1000  == 0 ? print STDERR "."  : 0 ;
        };

#       warn "## out ", dump( $out );

        return $affected;
}

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