line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# 2001/01/25 shizukesa@pobox.com |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package POE::Filter::Map; |
4
|
|
|
|
|
|
|
|
5
|
4
|
|
|
4
|
|
1459
|
use strict; |
|
4
|
|
|
|
|
4
|
|
|
4
|
|
|
|
|
119
|
|
6
|
4
|
|
|
4
|
|
1102
|
use POE::Filter; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
122
|
|
7
|
|
|
|
|
|
|
|
8
|
4
|
|
|
4
|
|
18
|
use vars qw($VERSION @ISA); |
|
4
|
|
|
|
|
4
|
|
|
4
|
|
|
|
|
205
|
|
9
|
|
|
|
|
|
|
$VERSION = '1.366'; # NOTE - Should be #.### (three decimal places) |
10
|
|
|
|
|
|
|
@ISA = qw(POE::Filter); |
11
|
|
|
|
|
|
|
|
12
|
4
|
|
|
4
|
|
30
|
use Carp qw(croak carp); |
|
4
|
|
|
|
|
4
|
|
|
4
|
|
|
|
|
314
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
sub BUFFER () { 0 } |
15
|
|
|
|
|
|
|
sub CODEGET () { 1 } |
16
|
|
|
|
|
|
|
sub CODEPUT () { 2 } |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub FIRST_UNUSED () { 3 } # First unused $self offset. |
19
|
|
|
|
|
|
|
|
20
|
4
|
|
|
4
|
|
16
|
use base 'Exporter'; |
|
4
|
|
|
|
|
5
|
|
|
4
|
|
|
|
|
1989
|
|
21
|
|
|
|
|
|
|
our @EXPORT_OK = qw( FIRST_UNUSED ); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
sub new { |
27
|
12
|
|
|
12
|
1
|
4458
|
my $type = shift; |
28
|
12
|
100
|
|
|
|
168
|
croak "$type must be given an even number of parameters" if @_ & 1; |
29
|
11
|
|
|
|
|
19
|
my %params = @_; |
30
|
|
|
|
|
|
|
|
31
|
11
|
100
|
100
|
|
|
414
|
croak "$type requires a Code or both Get and Put parameters" unless ( |
|
|
|
66
|
|
|
|
|
32
|
|
|
|
|
|
|
defined($params{Code}) or |
33
|
|
|
|
|
|
|
(defined($params{Get}) and defined($params{Put})) |
34
|
|
|
|
|
|
|
); |
35
|
8
|
100
|
|
|
|
132
|
croak "Code element is not a subref" |
|
|
100
|
|
|
|
|
|
36
|
|
|
|
|
|
|
unless (defined $params{Code} ? ref $params{Code} eq 'CODE' : 1); |
37
|
7
|
100
|
66
|
|
|
217
|
croak "Get or Put element is not a subref" |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
38
|
|
|
|
|
|
|
unless ((defined $params{Get} ? (ref $params{Get} eq 'CODE') : 1) |
39
|
|
|
|
|
|
|
and (defined $params{Put} ? (ref $params{Put} eq 'CODE') : 1)); |
40
|
|
|
|
|
|
|
|
41
|
5
|
|
66
|
|
|
13
|
my $get = $params{Code} || $params{Get}; |
42
|
5
|
|
66
|
|
|
12
|
my $put = $params{Code} || $params{Put}; |
43
|
|
|
|
|
|
|
|
44
|
5
|
|
|
|
|
8
|
delete @params{qw(Code Get Put)}; |
45
|
5
|
50
|
|
|
|
10
|
carp("$type ignores unknown parameters: ", join(', ', sort keys %params)) |
46
|
|
|
|
|
|
|
if scalar keys %params; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
|
49
|
5
|
|
|
|
|
23
|
my $self = bless [ |
50
|
|
|
|
|
|
|
[ ], # BUFFER |
51
|
|
|
|
|
|
|
$get, # CODEGET |
52
|
|
|
|
|
|
|
$put, # CODEPUT |
53
|
|
|
|
|
|
|
], $type; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
57
|
|
|
|
|
|
|
# get() is inherited from POE::Filter. |
58
|
|
|
|
|
|
|
# clone() is inherited from POE::Filter. |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
sub put { |
63
|
5
|
|
|
5
|
1
|
20
|
my ($self, $data) = @_; |
64
|
5
|
|
|
|
|
7
|
[ map { $self->[CODEPUT]->($_) } @$data ]; |
|
10
|
|
|
|
|
31
|
|
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
68
|
|
|
|
|
|
|
# 2001-07-26 RCC: The get_one variant of get() allows Wheel::Xyz to |
69
|
|
|
|
|
|
|
# retrieve one filtered record at a time. This is necessary for |
70
|
|
|
|
|
|
|
# filter changing and proper input flow control, even though it's kind |
71
|
|
|
|
|
|
|
# of slow. |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
sub get_one_start { |
74
|
9
|
|
|
9
|
1
|
10
|
my ($self, $stream) = @_; |
75
|
9
|
50
|
|
|
|
17
|
push(@{$self->[BUFFER]}, @$stream) if defined $stream; |
|
9
|
|
|
|
|
27
|
|
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
sub get_one { |
79
|
24
|
|
|
24
|
1
|
2906
|
my $self = shift; |
80
|
|
|
|
|
|
|
|
81
|
24
|
100
|
|
|
|
20
|
return [ ] unless @{$self->[BUFFER]}; |
|
24
|
|
|
|
|
53
|
|
82
|
17
|
|
|
|
|
15
|
my $next_record = shift @{$self->[BUFFER]}; |
|
17
|
|
|
|
|
19
|
|
83
|
17
|
|
|
|
|
17
|
return [ map { $self->[CODEGET]->($_) } $next_record ]; |
|
17
|
|
|
|
|
49
|
|
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
87
|
|
|
|
|
|
|
# 2001-07-27 RCC: This filter now tracks state, so get_pending has |
88
|
|
|
|
|
|
|
# become useful. |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
sub get_pending { |
91
|
2
|
|
|
2
|
1
|
4
|
my $self = shift; |
92
|
2
|
100
|
|
|
|
2
|
return undef unless @{$self->[BUFFER]}; |
|
2
|
|
|
|
|
5
|
|
93
|
1
|
|
|
|
|
1
|
[ @{$self->[BUFFER]} ]; |
|
1
|
|
|
|
|
4
|
|
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
sub modify { |
99
|
6
|
|
|
6
|
1
|
1582
|
my ($self, %params) = @_; |
100
|
|
|
|
|
|
|
|
101
|
6
|
|
|
|
|
13
|
for (keys %params) { |
102
|
6
|
100
|
50
|
|
|
377
|
(carp("Modify $_ element must be given a coderef") and next) unless (ref $params{$_} eq 'CODE'); |
103
|
3
|
100
|
|
|
|
8
|
if (lc eq 'code') { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
104
|
1
|
|
|
|
|
2
|
$self->[CODEGET] = $params{$_}; |
105
|
1
|
|
|
|
|
5
|
$self->[CODEPUT] = $params{$_}; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
elsif (lc eq 'put') { |
108
|
1
|
|
|
|
|
4
|
$self->[CODEPUT] = $params{$_}; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
elsif (lc eq 'get') { |
111
|
1
|
|
|
|
|
5
|
$self->[CODEGET] = $params{$_}; |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
1; |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
__END__ |