File Coverage

blib/lib/POE/Filter/Map.pm
Criterion Covered Total %
statement 52 52 100.0
branch 27 30 90.0
condition 12 17 70.5
subroutine 11 11 100.0
pod 6 6 100.0
total 108 116 93.1


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__