File: | lib/WWW/Google/Contacts/Roles/List.pm |
Coverage: | 25.8% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package WWW::Google::Contacts::Roles::List; | ||||||
2 | |||||||
3 | 11 11 11 | 82 36 122 | use Moose::Role; | ||||
4 | 11 11 11 | 119 32 133 | use MooseX::Types::Moose qw( ArrayRef Int ); | ||||
5 | 11 11 11 | 115 36 132 | use Carp qw( croak ); | ||||
6 | 11 11 11 | 100 33 161 | use URI::Escape; | ||||
7 | 11 11 11 | 102 41 113 | use Perl6::Junction qw( any ); | ||||
8 | 11 11 11 | 98 37 80 | use WWW::Google::Contacts::Data; | ||||
9 | |||||||
10 | requires 'baseurl', 'element_class'; | ||||||
11 | |||||||
12 | has elements => ( | ||||||
13 | isa => ArrayRef, | ||||||
14 | is => 'rw', | ||||||
15 | lazy_build => 1, | ||||||
16 | ); | ||||||
17 | |||||||
18 | has server => ( | ||||||
19 | is => 'ro', | ||||||
20 | required => 1, | ||||||
21 | ); | ||||||
22 | |||||||
23 | has pointer => ( | ||||||
24 | isa => Int, | ||||||
25 | is => 'rw', | ||||||
26 | default => 0, | ||||||
27 | init_arg => undef, | ||||||
28 | ); | ||||||
29 | |||||||
30 | sub search { | ||||||
31 | 0 | 0 | my ($self, $search) = @_; | ||||
32 | |||||||
33 | 0 | my $class = $self->element_class; | |||||
34 | |||||||
35 | # TODO - make something clever to match XML keys without having to bless all the objects for comparison | ||||||
36 | # this could be a start; | ||||||
37 | # | ||||||
38 | #my $element = $class->new( server => $self->server ); | ||||||
39 | #my $search_params = []; | ||||||
40 | #foreach my $key ( keys %{ $search } ) { | ||||||
41 | # my $xml_key = $element->get_xml_key( $key ); | ||||||
42 | # if ( $xml_key ) { | ||||||
43 | # push @{ $search_params }, | ||||||
44 | # { | ||||||
45 | # xml_key => $xml_key, | ||||||
46 | # value => $search->{ $key }, | ||||||
47 | # }; | ||||||
48 | # } | ||||||
49 | # else { | ||||||
50 | # croak "Can't find XML key for [$key]"; | ||||||
51 | # } | ||||||
52 | #} | ||||||
53 | |||||||
54 | # This doesn't scale well.... SLOW | ||||||
55 | 0 | my $to_ret = []; | |||||
56 | 0 | ELEM: | |||||
57 | 0 | foreach my $elem ( @{ $self->elements } ) { | |||||
58 | 0 | my $obj = $class->new( server => $self->server ); | |||||
59 | 0 | $obj->set_from_server( $elem ); | |||||
60 | 0 0 | foreach my $key ( keys %{ $search } ) { | |||||
61 | 0 | next ELEM unless ( defined $obj->$key ); | |||||
62 | 0 | if ( ref( $obj->$key ) and ref( $obj->$key ) eq 'ARRAY' ) { | |||||
63 | 0 | my $search_field = $obj->$key->[0]->search_field; | |||||
64 | 0 | next ELEM unless ( defined $search_field ); | |||||
65 | 0 0 0 | my @values = map { $_->$search_field } @{ $obj->$key }; | |||||
66 | 0 | next ELEM unless ( any(@values) eq $search->{ $key } ); | |||||
67 | } | ||||||
68 | else { | ||||||
69 | 0 | next ELEM unless ( $obj->$key eq $search->{ $key } ); | |||||
70 | } | ||||||
71 | } | ||||||
72 | 0 0 | push @{ $to_ret }, $obj; | |||||
73 | } | ||||||
74 | 0 0 | return wantarray ? @{ $to_ret } : $to_ret; | |||||
75 | } | ||||||
76 | |||||||
77 | sub next { | ||||||
78 | 0 | 0 | my $self = shift; | ||||
79 | 0 | return undef unless ( $self->elements->[ $self->pointer ] ); | |||||
80 | 0 | my $next = $self->elements->[ $self->pointer ]; | |||||
81 | 0 | $self->pointer( $self->pointer+1 ); | |||||
82 | 0 | my $class = $self->element_class; | |||||
83 | 0 | return $class->new( server => $self->server )->set_from_server( $next ); | |||||
84 | } | ||||||
85 | |||||||
86 | sub _build_elements { | ||||||
87 | 0 | my $self = shift; | |||||
88 | |||||||
89 | 0 | my $args = {}; | |||||
90 | 0 | $args->{'alt'} = 'atom'; # must be atom | |||||
91 | 0 | $args->{'max-results'} ||= 9999; | |||||
92 | 0 | my $group = delete $args->{group} || 'full'; | |||||
93 | 0 | my $url = sprintf( '%s/%s?v=3.0', $self->baseurl, uri_escape($group) ); | |||||
94 | 0 | foreach my $key (keys %$args) { | |||||
95 | 0 | $url .= '&' . uri_escape($key) . '=' . uri_escape($args->{$key}); | |||||
96 | } | ||||||
97 | 0 | my $res = $self->server->get( $url ); | |||||
98 | 0 | my $content = $res->content; | |||||
99 | 0 | my $data = WWW::Google::Contacts::Data->decode_xml( $content ); | |||||
100 | 0 | my $array = $data->{ entry } || []; | |||||
101 | |||||||
102 | #use Data::Dumper; | ||||||
103 | #print Dumper $array->[0]; | ||||||
104 | #die; | ||||||
105 | |||||||
106 | # ..lots of overhead to bless them all now. | ||||||
107 | #my $class = $self->element_class; | ||||||
108 | #$array = [ map { $class->new( server => $self->server )->set_from_server( $_ ) } @{ $array } ]; | ||||||
109 | 0 | return $array; | |||||
110 | } | ||||||
111 | |||||||
112 | 1; |