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