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