| File: | lib/WWW/Google/Contacts.pm |
| Coverage: | 30.3% |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 1 | package WWW::Google::Contacts; | ||||||
| 2 | |||||||
| 3 | # ABSTRACT: Google Contacts Data API | ||||||
| 4 | |||||||
| 5 | 11 11 11 | 141 39 99 | use Moose; | ||||
| 6 | |||||||
| 7 | 11 11 11 | 137 35 89 | use Carp qw/croak/; | ||||
| 8 | |||||||
| 9 | 11 11 11 | 173 45 147 | use WWW::Google::Contacts::Server; | ||||
| 10 | 11 11 11 | 206 46 525 | use WWW::Google::Contacts::Contact; | ||||
| 11 | 11 11 11 | 209 44 170 | use WWW::Google::Contacts::ContactList; | ||||
| 12 | 11 11 11 | 199 45 187 | use WWW::Google::Contacts::Group; | ||||
| 13 | 11 11 11 | 206 45 177 | use WWW::Google::Contacts::GroupList; | ||||
| 14 | |||||||
| 15 | has username => ( | ||||||
| 16 | isa => 'Str', | ||||||
| 17 | is => 'rw', | ||||||
| 18 | default => sub { $ENV{ GOOGLE_USERNAME } }, | ||||||
| 19 | ); | ||||||
| 20 | |||||||
| 21 | has password => ( | ||||||
| 22 | isa => 'Str', | ||||||
| 23 | is => 'rw', | ||||||
| 24 | default => sub { $ENV{ GOOGLE_PASSWORD } }, | ||||||
| 25 | ); | ||||||
| 26 | |||||||
| 27 | has server => ( | ||||||
| 28 | isa => 'Object', | ||||||
| 29 | is => 'ro', | ||||||
| 30 | lazy_build => 1, | ||||||
| 31 | ); | ||||||
| 32 | |||||||
| 33 | # backward compability | ||||||
| 34 | has email => ( isa => 'Str', is => 'rw', trigger => sub { $_[0]->username( $_[1] ) } ); | ||||||
| 35 | has pass => ( isa => 'Str', is => 'rw', trigger => sub { $_[0]->password( $_[1] ) } ); | ||||||
| 36 | |||||||
| 37 | sub _build_server { | ||||||
| 38 | 2 | 129 | my $self = shift; | ||||
| 39 | 2 | 17 | return WWW::Google::Contacts::Server->new({ | ||||
| 40 | username => $self->username, | ||||||
| 41 | password => $self->password, | ||||||
| 42 | }); | ||||||
| 43 | } | ||||||
| 44 | |||||||
| 45 | sub new_contact { | ||||||
| 46 | 3 | 1 | 16 | my $self = shift; | |||
| 47 | 1 | 10 | my $args = ( scalar(@_) == 1 and ref($_[0]) eq 'HASH' ) | ||||
| 48 | 3 | 46 | ? { %{$_[0]}, server => $self->server } | ||||
| 49 | : { @_, server => $self->server }; | ||||||
| 50 | 3 | 454 | return WWW::Google::Contacts::Contact->new($args); | ||||
| 51 | } | ||||||
| 52 | |||||||
| 53 | sub contact { | ||||||
| 54 | 0 | 1 | my ($self,$id) = @_; | ||||
| 55 | 0 | return WWW::Google::Contacts::Contact->new( id => $id, server => $self->server )->retrieve; | |||||
| 56 | } | ||||||
| 57 | |||||||
| 58 | sub contacts { | ||||||
| 59 | 0 | 1 | my $self = shift; | ||||
| 60 | |||||||
| 61 | 0 | my $list = WWW::Google::Contacts::ContactList->new( server => $self->server ); | |||||
| 62 | 0 | return $list; | |||||
| 63 | } | ||||||
| 64 | |||||||
| 65 | sub new_group { | ||||||
| 66 | 0 | 1 | my $self = shift; | ||||
| 67 | 0 | my $args = ( scalar(@_) == 1 and ref($_[0]) eq 'HASH' ) | |||||
| 68 | 0 | ? { %{$_[0]}, server => $self->server } | |||||
| 69 | : { @_, server => $self->server }; | ||||||
| 70 | 0 | return WWW::Google::Contacts::Group->new( $args ); | |||||
| 71 | } | ||||||
| 72 | |||||||
| 73 | sub group { | ||||||
| 74 | 0 | 1 | my ($self,$id) = @_; | ||||
| 75 | 0 | return WWW::Google::Contacts::Group->new( id => $id,server => $self->server )->retrieve; | |||||
| 76 | } | ||||||
| 77 | |||||||
| 78 | sub groups { | ||||||
| 79 | 0 | 1 | my $self = shift; | ||||
| 80 | |||||||
| 81 | 0 | my $list = WWW::Google::Contacts::GroupList->new( server => $self->server ); | |||||
| 82 | 0 | return $list; | |||||
| 83 | } | ||||||
| 84 | |||||||
| 85 | # All code below is for backwards compability | ||||||
| 86 | |||||||
| 87 | sub login { | ||||||
| 88 | 0 | 1 | my ($self, $email, $pass) = @_; | ||||
| 89 | 0 | warn "This method is deprecated and will be removed shortly"; | |||||
| 90 | 0 | $self->email( $email ); | |||||
| 91 | 0 | $self->pass( $pass ); | |||||
| 92 | 0 | my $server = WWW::Google::Contacts::Server->new({ username => $self->email, password => $self->password }); | |||||
| 93 | 0 | $server->authenticate; | |||||
| 94 | 0 | return 1; | |||||
| 95 | } | ||||||
| 96 | |||||||
| 97 | sub create_contact { | ||||||
| 98 | 0 | 1 | my $self = shift; | ||||
| 99 | 0 | warn "This method is deprecated and will be removed shortly"; | |||||
| 100 | 0 | my $data = scalar @_ % 2 ? shift : { @_ }; | |||||
| 101 | |||||||
| 102 | 0 | my $contact = $self->new_contact; | |||||
| 103 | 0 | return $self->_create_or_update_contact( $contact, $data ); | |||||
| 104 | } | ||||||
| 105 | |||||||
| 106 | sub _create_or_update_contact { | ||||||
| 107 | 0 | my ($self, $contact, $data) = @_; | |||||
| 108 | |||||||
| 109 | 0 | $contact->given_name( $data->{ givenName } ); | |||||
| 110 | 0 | $contact->family_name( $data->{ familyName } ); | |||||
| 111 | 0 | $contact->notes( $data->{Notes} ); | |||||
| 112 | $contact->email({ | ||||||
| 113 | type => "work", | ||||||
| 114 | primary => 1, | ||||||
| 115 | value => $data->{ primaryMail }, | ||||||
| 116 | display_name => $data->{ displayName }, | ||||||
| 117 | 0 | }); | |||||
| 118 | 0 | if ( $contact->{secondaryMail} ) { | |||||
| 119 | $contact->add_email({ | ||||||
| 120 | type => "home", | ||||||
| 121 | value => $data->{ secondaryMail }, | ||||||
| 122 | 0 | }); | |||||
| 123 | } | ||||||
| 124 | # if ( $contact->{groupMembershipInfo} ) { | ||||||
| 125 | # $data->{'atom:entry'}->{'gContact:groupMembershipInfo'} = { | ||||||
| 126 | # deleted => 'false', | ||||||
| 127 | # href => $contact->{groupMembershipInfo} | ||||||
| 128 | # }; | ||||||
| 129 | # } | ||||||
| 130 | 0 | if ( $contact->create_or_update ) { | |||||
| 131 | 0 | return 1; | |||||
| 132 | } | ||||||
| 133 | 0 | return 0; | |||||
| 134 | } | ||||||
| 135 | |||||||
| 136 | sub get_contacts { | ||||||
| 137 | 0 | 1 | my $self = shift; | ||||
| 138 | |||||||
| 139 | 0 | warn "This method is deprecated and will be removed shortly"; | |||||
| 140 | 0 | my $list = $self->contacts; | |||||
| 141 | 0 | my @contacts; | |||||
| 142 | 0 0 | foreach my $c ( @{ $list->elements } ) { | |||||
| 143 | 0 | my $d = $c; | |||||
| 144 | ($d->{id}) = | ||||||
| 145 | 0 | map { $_->{ href } } | |||||
| 146 | 0 | grep { $_->{ rel } eq 'self' } | |||||
| 147 | 0 0 | @{ $d->{ link } } | |||||
| 148 | ; | ||||||
| 149 | 0 | $d->{name} = $d->{'gd:name'}; | |||||
| 150 | 0 | $d->{email} = $d->{'gd:email'}; | |||||
| 151 | 0 | $d->{groupMembershipInfo} = $d->{'gContact:groupMembershipInfo'}; | |||||
| 152 | 0 | push @contacts, $d; | |||||
| 153 | } | ||||||
| 154 | 0 | return @contacts; | |||||
| 155 | } | ||||||
| 156 | |||||||
| 157 | sub get_contact { | ||||||
| 158 | 0 | 1 | my ($self, $id) = @_; | ||||
| 159 | |||||||
| 160 | 0 | warn "This method is deprecated and will be removed shortly"; | |||||
| 161 | 0 | my $contact = $self->new_contact( id => $id )->retrieve; | |||||
| 162 | 0 | my $data = $contact->raw_data_for_backwards_compability; | |||||
| 163 | 0 | $data->{name} = $data->{'gd:name'}; | |||||
| 164 | 0 | $data->{email} = $data->{'gd:email'}; | |||||
| 165 | 0 | $data->{groupMembershipInfo} = $data->{'gContact:groupMembershipInfo'}; | |||||
| 166 | 0 | return $data; | |||||
| 167 | } | ||||||
| 168 | |||||||
| 169 | sub update_contact { | ||||||
| 170 | 0 | 1 | my ($self, $id, $contact) = @_; | ||||
| 171 | |||||||
| 172 | 0 | warn "This method is deprecated and will be removed shortly"; | |||||
| 173 | 0 | my $c = $self->new_contact( id => $id )->retrieve; | |||||
| 174 | 0 | return $self->_create_or_update_contact( $c, $contact ); | |||||
| 175 | } | ||||||
| 176 | |||||||
| 177 | sub delete_contact { | ||||||
| 178 | 0 | 1 | my ($self, $id) = @_; | ||||
| 179 | |||||||
| 180 | 0 | warn "This method is deprecated and will be removed shortly"; | |||||
| 181 | 0 | $self->new_contact( id => $id )->delete; | |||||
| 182 | } | ||||||
| 183 | |||||||
| 184 | sub get_groups { | ||||||
| 185 | 0 | 1 | my $self = shift; | ||||
| 186 | |||||||
| 187 | 0 | warn "This method is deprecated and will be removed shortly"; | |||||
| 188 | 0 | my $list = $self->groups; | |||||
| 189 | 0 | my @groups; | |||||
| 190 | 0 0 | foreach my $d ( @{ $list->elements } ) { | |||||
| 191 | 0 | my $link = ref($d->{link}) eq 'ARRAY' ? $d->{link} : [ $d->{link} ]; | |||||
| 192 | ($d->{id}) = | ||||||
| 193 | 0 | map { $_->{ href } } | |||||
| 194 | 0 0 | grep { $_->{ rel } eq 'self' } | |||||
| 195 | 0 | @{ $link } | |||||
| 196 | ; | ||||||
| 197 | 0 | push @groups, { | |||||
| 198 | id => $d->{id}, | ||||||
| 199 | title => $d->{title}, | ||||||
| 200 | updated => $d->{updated}, | ||||||
| 201 | exists $d->{'gContact:systemGroup'} ? ('gContact:systemGroup' => $d->{'gContact:systemGroup'}->{'id'}) : (), | ||||||
| 202 | } | ||||||
| 203 | } | ||||||
| 204 | 0 | return @groups; | |||||
| 205 | } | ||||||
| 206 | |||||||
| 207 | sub get_group { | ||||||
| 208 | 0 | 1 | my ($self, $id) = @_; | ||||
| 209 | |||||||
| 210 | 0 | warn "This method is deprecated and will be removed shortly"; | |||||
| 211 | 0 | my $group = $self->new_group( id => $id )->retrieve; | |||||
| 212 | 0 | my $data = $group->raw_data_for_backwards_compability; | |||||
| 213 | 0 | return $data; | |||||
| 214 | } | ||||||
| 215 | |||||||
| 216 | sub _create_or_update_group { | ||||||
| 217 | 0 | my ($self, $group, $data) = @_; | |||||
| 218 | |||||||
| 219 | 0 | $group->title( $data->{ title } ); | |||||
| 220 | 0 | if ( $group->create_or_update ) { | |||||
| 221 | 0 | return 1; | |||||
| 222 | } | ||||||
| 223 | 0 | return 0; | |||||
| 224 | } | ||||||
| 225 | |||||||
| 226 | sub create_group { | ||||||
| 227 | 0 | 1 | my $self = shift; | ||||
| 228 | 0 | my $data = scalar @_ % 2 ? shift : { @_ }; | |||||
| 229 | |||||||
| 230 | 0 | warn "This method is deprecated and will be removed shortly"; | |||||
| 231 | 0 | my $group = $self->new_group; | |||||
| 232 | 0 | return $self->_create_or_update_group( $group, $data ); | |||||
| 233 | } | ||||||
| 234 | |||||||
| 235 | sub update_group { | ||||||
| 236 | 0 | 1 | my ($self, $id, $args) = @_; | ||||
| 237 | |||||||
| 238 | 0 | warn "This method is deprecated and will be removed shortly"; | |||||
| 239 | 0 | my $g = $self->new_group( id => $id )->retrieve; | |||||
| 240 | 0 | return $self->_create_or_update_group( $g, $args ); | |||||
| 241 | } | ||||||
| 242 | |||||||
| 243 | sub delete_group { | ||||||
| 244 | 0 | 1 | my ($self, $id) = @_; | ||||
| 245 | |||||||
| 246 | 0 | warn "This method is deprecated and will be removed shortly"; | |||||
| 247 | 0 | $self->new_group( id => $id )->delete; | |||||
| 248 | } | ||||||
| 249 | |||||||
| 250 | 11 11 11 | 156 45 93 | no Moose; | ||||
| 251 | __PACKAGE__->meta->make_immutable; | ||||||
| 252 | 1; | ||||||