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;
                }

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

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

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

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

1;
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	eval { $coderef->( $data->[$pos] ) };
50
51	if ( $@ ) {
52	warn "ABORT at $pos error $@\n";
53	last;
54	} else {
55	$affected++;
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
65	1;