File Coverage

blib/lib/Net/CardDAVTalk/VCard.pm
Criterion Covered Total %
statement 26 434 5.9
branch 0 196 0.0
condition 0 185 0.0
subroutine 9 56 16.0
pod 5 41 12.2
total 40 912 4.3


line stmt bran cond sub pod time code
1             package Net::CardDAVTalk::VCard;
2              
3 2     2   40 use 5.014;
  2         8  
4 2     2   21 use strict;
  2         3  
  2         39  
5 2     2   8 use warnings;
  2         3  
  2         59  
6 2     2   15 use Text::VCardFast qw(vcard2hash hash2vcard);
  2         3  
  2         96  
7 2     2   11 use Encode qw(decode_utf8 encode_utf8);
  2         3  
  2         92  
8 2     2   10 use MIME::Base64 qw(decode_base64);
  2         4  
  2         73  
9 2     2   619 use List::Pairwise qw(mapp);
  2         3426  
  2         137  
10 2     2   826 use List::MoreUtils qw(all pairwise);
  2         19550  
  2         14  
11 2     2   2665 use Data::Dumper;
  2         9357  
  2         4191  
12              
13             =head1 NAME
14              
15             Net::CardDAVTalk::VCard - A wrapper for VCard files
16              
17             =head1 SUBROUTINES/METHODS
18              
19             # Core {{{
20              
21             =head2 $class->new()
22              
23             Create a basic VCard object with no fields set
24              
25             =cut
26              
27             sub new {
28 0     0 1   my $Proto = shift;
29 0   0       my $Class = ref($Proto) || $Proto;
30              
31 0           my $Self = {
32             type => 'VCARD',
33             properties => {
34             version => [
35             {
36             name => "version",
37             value => "3.0"
38             },
39             ],
40             }
41             };
42              
43 0           return bless $Self, $Class;
44             }
45              
46             =head2 $class->new_fromstring($String)
47              
48             Create a new object and populate it by parsing the VCard file
49             who's contents are given in the string.
50              
51             =cut
52              
53             sub new_fromstring {
54 0     0 1   my $Proto = shift;
55 0   0       my $Class = ref($Proto) || $Proto;
56 0           my $Data = shift;
57              
58 0           my $Parsed = eval { vcard2hash($Data, multival => [ qw(n adr org) ]) };
  0            
59              
60 0           my $Self = $Parsed->{objects}->[0];
61 0 0         if ($Self->{type} ne 'vcard') {
62 0           warn "Found non-vcard '$Self->{type}' for in $_";
63 0           return undef;
64             }
65              
66 0           bless $Self, $Class;
67              
68 0           $Self->Normalise();
69              
70 0           $Self->{_raw} = $Data;
71              
72 0           return $Self;
73             }
74              
75             =head2 $class->new_fromfile($File)
76              
77             Given a filename or filehandle, read and parse a vcard from it.
78              
79             =cut
80              
81             sub new_fromfile {
82 0     0 1   my $Proto = shift;
83 0   0       my $Class = ref($Proto) || $Proto;
84              
85 0           my $FileR = shift;
86              
87 0           my $Fh;
88 0 0         if (ref $FileR) {
89 0           $Fh = $FileR;
90             } else {
91 0 0         open($Fh, $FileR)
92             || die "Could not read '$FileR': $!";
93             }
94              
95 0           my $Input = do { local $/; <$Fh>; };
  0            
  0            
96              
97 0           my $Self = $Class->new_fromstring($Input);
98 0 0         $Self->{file} = $FileR if !ref $FileR;
99              
100 0           return $Self;
101             }
102              
103             =head2 $self->as_string()
104              
105             Return a string representation of the VCard (inverse of
106             new_fromstring)
107              
108             =cut
109              
110             sub as_string {
111 0     0 1   my $Self = shift;
112 0           delete $Self->{_raw};
113 0           $Self->{_raw} = eval { hash2vcard({ objects => [ $Self ] }) };
  0            
114 0           return $Self->{_raw};
115             }
116              
117             =head2 $self->uid()
118              
119             Get or set the uid field of the card.
120              
121             =cut
122              
123             sub uid {
124 0     0 1   my $Self = shift;
125 0           $Self->V('uid', 'value', @_);
126             }
127              
128             # }}}
129              
130             # ME VCard manipulation {{{
131              
132             my @VParamTypes = qw(work home text voice fax cell cell video pager textphone internet);
133             push @VParamTypes, map { uc } @VParamTypes;
134              
135             my @VItemN = qw(surnames givennames additionalnames honorificprefixs honorificsuffixes);
136             my @VItemADR = qw(postofficebox extendedaddress streetaddress locality region postalcode countryname);
137             my @VItemORG = qw(company department);
138             my %VExpand = (n => \@VItemN, adr => \@VItemADR, org => \@VItemORG);
139              
140             my @ProtoPrefixes = (
141             [ 'tel', qr/tel:/ ],
142             [ 'impp', qr/skype:/ ],
143             [ 'impp', qr/xmpp:/ ],
144             [ 'x-skype', qr/skype:/ ],
145             [ 'x-socialprofile', qr/twitter:/ ],
146             );
147              
148             my %ABLabelTypeMap = (Home => 'home', Mobile => 'cell', Twitter => 'twitter');
149              
150             my %VCardEmailTypeMap = (
151             home => 'personal',
152             work => 'work',
153             );
154             my %RevVCardEmailTypeMap = reverse %VCardEmailTypeMap;
155              
156             my %VCardAdrTypeMap = (
157             home => 'home',
158             work => 'work',
159             );
160             my %RevVCardAdrTypeMap = reverse %VCardAdrTypeMap;
161              
162             my %VCardTelTypeMap = (
163             home => 'home',
164             work => 'work',
165             cell => 'mobile',
166             fax => 'fax',
167             pager => 'pager',
168             );
169             my %RevVCardTelTypeMap = reverse %VCardTelTypeMap;
170              
171             my %VCardTypeMap = (
172             email => [ \%VCardEmailTypeMap, \%RevVCardEmailTypeMap ],
173             adr => [ \%VCardAdrTypeMap, \%RevVCardAdrTypeMap ],
174             tel => [ \%VCardTelTypeMap, \%RevVCardTelTypeMap ],
175             );
176              
177             my %IMPPServiceTypeMap = qw(
178             skype skype
179             );
180              
181             my %IMPPProtoPrefixes = (
182             'skype' => ['skype'],
183             'msn' => ['msn','msnim'],
184             'googletalk' => ['xmpp'],
185             'facebook' => ['xmpp'],
186             'aim' => ['aim'],
187             'yahoo' => ['ymsgr'],
188             'icq' => ['icq','aim'],
189             'jabber' => ['xmpp'],
190             );
191              
192             my %XSocialProfileTypeMap = qw(
193             twitter twitter
194             );
195              
196             my %XServiceTypeMap = qw(
197             twitter twitter
198             skype skype
199             skype-username skype
200             aim chat
201             icq chat
202             google-talk chat
203             jabber chat
204             msn chat
205             yahoo chat
206             ms-imaddress chat
207             );
208              
209             my %VCardNewOnlineMap = (
210             'web' => [
211             [ 'url' ]
212             ],
213             'chat' => sub { [
214             [ 'impp', { 'x-service-type' => 'jabber', 'x-user' => $_[0] } ],
215             ] },
216             'twitter' => sub { [
217             [ 'x-socialprofile', { 'type' => 'twitter', 'x-user' => $_[0] }, "http://twitter.com/$_[0]" ],
218             [ 'x-twitter' ],
219             ] },
220             'skype' => sub { [
221             [ 'impp', { 'x-service-type' => 'skype', 'x-user' => $_[0] } ],
222             [ 'x-skype' ],
223             ] },
224             'other' => sub { [
225             [ 'impp', { 'x-user' => $_[0] } ],
226             ] },
227             );
228              
229             my $NoteParamName = 'x-menote';
230              
231             sub Normalise {
232 0     0 0   my $Self = shift;
233              
234 0           $Self->{meta} = {};
235              
236 0           my $Props = $Self->{properties};
237              
238             # Expand/decode/normalise all values
239 0           for (values %$Props) {
240              
241             # All properties are array ref of items
242 0           for (@$_) {
243              
244             # Scalar or array ref (e.g. 'n', 'adr', etc compound fields)
245 0   0       my $Value = $_->{value} // $_->{values};
246              
247             # If non-ascii value, it's utf-8
248 0 0         for (ref($Value) ? @$Value : $Value) {
249 0 0         if (/[\x80-\xff]/) {
250 0   0       $_ = eval { decode_utf8($_) } // $_;
  0            
251             }
252             }
253              
254             # Expand out 'n' and 'adr' fields into components.
255             # Put scalars into expanded fields and scalar refs in values arrayref
256 0 0         if (my $VFields = $VExpand{$_->{name}}) {
257 0   0       @$_{@$VFields} = map { $_ // '' } @$Value[0 .. scalar(@$VFields)-1];
  0            
258 0           $_->{values} = [ \@$_{@$VFields} ];
259 0           delete $_->{value};
260             }
261              
262             # Handle base64 encoded value
263 0           my $Encoding = $_->{params}->{encoding};
264 0 0 0       if (ref($Encoding) && lc $Encoding->[0] eq 'b') {
265 0           $Value = decode_base64($Value);
266 0           $_->{binary} = 1;
267             }
268              
269             # Expand and lowercase comma separated type= parameters
270 0 0         if (my $Type = $_->{params}->{type}) {
271 0 0         $_->{params}->{type} = $Type = [ $Type ] if !ref $Type;
272 0           @$Type = map { split /,/, lc $_ } @$Type;
  0            
273             }
274 0 0         if (my $ServiceType = $_->{params}->{'x-service-type'}) {
275 0 0         $_->{params}->{'x-service-type'} = $ServiceType = [ $ServiceType ] if !ref $ServiceType;
276             }
277              
278 0           $_->{value} = $Value;
279              
280             # Create 'groups' item that tracks items in each group
281 0 0         push @{$Self->{groups}->{$_->{group}}}, $_ if $_->{group};
  0            
282             }
283             }
284              
285             # Add any X-ABLabel group items as 'label' attribute
286 0 0         if (my $Labels = $Props->{'x-ablabel'}) {
287 0 0         my %LabelMap = map { $_->{group} ? ($_->{group} => $_) : () } @$Labels;
  0            
288 0           for (keys %$Props) {
289 0 0         next if $_ eq 'x-ablabel';
290 0           for (@{$Props->{$_}}) {
  0            
291 0 0 0       if (my $Label = $LabelMap{$_->{group} // ''}) {
292 0           my $LabelV = $_->{label} = $Label->{value};
293 0           $_->{labelref} = $Label;
294              
295             # Attach type= param if appropriate
296 0 0         $LabelV = $1 if $LabelV =~ m{^_\$\!<([^>]*)};
297 0 0         if (my $TypeP = $ABLabelTypeMap{$LabelV}) {
298 0   0       my $TypeList = ($_->{params}->{type} //= []);
299 0 0         push @$TypeList, $TypeP if !grep { $_ eq $TypeP } @$TypeList;
  0            
300             }
301             }
302             }
303             }
304             }
305              
306             # Handle v4 value=uri telephone numbers
307 0           my $Version = $Props->{version};
308 0 0 0       if ($Version && $Version->[0] >= 4.0) {
309 0           for (@ProtoPrefixes) {
310 0           my ($Prop, $ProtoRE) = @$_;
311 0 0         if (my $Items = $Props->{$Prop}) {
312 0           for (@$Items) {
313 0 0         if ($_->{value} =~ s/^($ProtoRE)//) {
314 0           $_->{proto_strip} = $1;
315             # If we found a uri prefix, better have value=uri param
316 0 0 0       if (!$_->{params}->{value} && $Prop eq 'tel') {
317 0           $_->{params}->{value} = [ 'uri' ];
318             }
319             }
320             }
321             }
322             }
323             }
324              
325             # Create synthetic "online" list. Generate "online_type" and "online_value"
326             # based on all the different types for twitter and skype contact info
327 0           my $Online = $Props->{online} = [];
328              
329             # URL:foo.com
330 0           for (@{$Props->{url}}) {
  0            
331 0           $_->{online_type} = 'web';
332 0           $_->{online_value} = $_->{value};
333              
334 0           push @$Online, $_;
335             }
336              
337             # IMPP;X-SERVICE-TYPE=Skype;type=pref:skype:someskype
338 0           for (@{$Props->{impp}}) {
  0            
339 0   0       my $Type = lc(($_->{params}->{'x-service-type'} // [])->[0] // '');
      0        
340 0           my $Value = $_->{value};
341 0   0       my $ProtoPrefixes = $IMPPProtoPrefixes{$Type} // ['x-apple'];
342 0           $Value =~ s/^$_:// for @$ProtoPrefixes;
343 0   0       $_->{online_type} = $IMPPServiceTypeMap{$Type} // 'chat';
344 0           $_->{online_value} = $Value;
345              
346 0           push @$Online, $_;
347             }
348              
349             # X-SOCIALPROFILE;type=twitter;x-user=sometwitter:http://twitter.com/sometwitter
350 0           for (@{$Props->{'x-socialprofile'}}) {
  0            
351 0   0       my $Type = lc(($_->{params}->{type} // [])->[0] // '');
      0        
352 0   0       my $Value = $_->{params}->{'x-user'}->[0] // $_->{value};
353 0   0       $_->{online_type} = $XSocialProfileTypeMap{$Type} // 'other';
354 0           $_->{online_value} = $Value;
355              
356 0           push @$Online, $_;
357             }
358              
359             # X-YAHOO:someyahoo
360 0           for my $Type (keys %XServiceTypeMap) {
361 0           for (@{$Props->{"x-$Type"}}) {
  0            
362 0           $_->{online_type} = $XServiceTypeMap{$Type};
363 0           $_->{online_value} = $_->{value};
364              
365 0           push @$Online, $_;
366             }
367             }
368              
369             # Set contact_type to match API
370 0           for ([ 'email', \%VCardEmailTypeMap ],
371             [ 'tel', \%VCardTelTypeMap ],
372             [ 'adr', \%VCardAdrTypeMap ]) {
373 0           my ($Prop, $Map) = @$_;
374              
375 0   0       my $Props = $Props->{$Prop} || next;
376 0           for (@$Props) {
377             # Prefer calculated online_type, otherwise case on property name or type params
378             my ($ContactType) =
379 0 0 0       map { ($_ && $Map->{$_}) or () }
380 0   0       (($_->{online_type} or ()), $_->{name}, @{$_->{params}->{type} // []});
  0   0        
381              
382 0   0       $_->{contact_type} = $ContactType // 'other';
383             }
384             }
385             }
386              
387             sub DeleteUnusedLabels {
388 0     0 0   my ($Self) = @_;
389 0           my $Props = $Self->{properties};
390              
391 0           for (@{$Props->{'x-ablabel'}}) {
  0            
392 0           my $Group = $Self->{groups}->{$_->{group}};
393 0           my $NumItems = grep { !$_->{deleted} } @$Group;
  0            
394 0 0         $_->{deleted} = 1 if $NumItems <= 1;
395             }
396             }
397              
398             sub ReadOnly {
399 0 0   0 0   $_[0]->{ReadOnly} = $_[1] if @_ > 1; return $_[0]->{ReadOnly};
  0            
400             }
401              
402             sub V {
403 0     0 0   my ($Self, $Prop, $Item) = splice @_, 0, 3;
404 0   0       $Item //= 'value';
405 0           my $Props = $Self->{properties};
406              
407             die "Tried to modify read-only contact, fetch directly, not from cache"
408 0 0 0       if @_ && $Self->{ReadOnly};
409              
410             # Always get/set first item of given type
411 0   0       my $V = $Props->{$Prop} && $Props->{$Prop}->[0];
412              
413             # If setting value, and no existing value, create new
414 0 0 0       if (!$V && @_) {
415 0           $V = $Props->{$Prop}->[0] = { name => $Prop, params => {} };
416              
417             # Create parts if an multipart field
418 0 0         if (my $VFields = $VExpand{$Prop}) {
419 0           @$V{@$VFields} = ("") x scalar @$VFields;
420 0           $V->{values} = [ \@$V{@$VFields} ];
421             }
422             }
423              
424             # Get value
425 0 0         if (!@_) {
426 0 0         return $V ? $V->{$Item} : undef;
427              
428             # Set value
429             } else {
430 0           $Self->{vchanged}->{$Prop} = 1;
431              
432 0           local $_ = shift;
433              
434 0 0         if (defined $_) {
435             # Trim whitespace and garbage from values
436 0           s/^\s+//;
437 0           s/\s+$//;
438             # Ugg, saw U+200B (ZERO WIDTH SPACE) in some data, http://www.perlmonks.org/?node_id=1020973
439 0           s/\p{FORMAT}//g;
440             }
441              
442             # Delete item if not a compound value and setting to empty string or undef
443 0 0 0       if ((!defined $_ || $_ eq '') && !$V->{values}) {
      0        
444 0           my $E = shift @{$Props->{$Prop}};
  0            
445 0           $E->{deleted} = 1;
446             }
447              
448             # Otherwise store the new value
449             else {
450 0   0       $V->{$Item} = $_ // '';
451              
452             # Uggg, for compound value, delete if all values empty
453 0 0 0 0     if ($V->{values} && all { $$_ eq '' } @{$V->{values}} ) {
  0            
  0            
454 0           my $E = shift @{$Props->{$Prop}};
  0            
455 0           $E->{deleted} = 1;
456             }
457             }
458              
459 0           $Self->DeleteUnusedLabels;
460              
461 0 0 0       $Self->VRebuildFN if $Prop eq 'n' || $Prop eq 'org';
462 0           return $_;
463             }
464             }
465              
466             sub VDate {
467 0     0 0   my $Self = shift;
468 0           local $_ = shift;
469              
470             # Convert VCard -> Our format
471 0 0         if (!@_) {
472 0 0         return undef if !$_;
473              
474 0 0         if (/^(\d{4})-(\d{2})-(\d{2})(?:T|$)/) {
475 0           my ($Y, $M, $D) = ($1, $2, $3);
476 0 0         $Y = '0000' if $Y eq '1604'; # iOS magic "no year" value
477 0           return "$Y-$M-$D";
478             }
479              
480             # V4 format
481 0 0         if (/^(\d{4}|--)(\d{2})(\d{2})(?:T|$)/) {
482 0           my ($Y, $M, $D) = ($1, $2, $3);
483 0 0         $Y = '0000' if $Y eq '--';
484 0 0         $Y = '0000' if $Y eq '1604'; # iOS magic "no year" value
485 0           return "$Y-$M-$D";
486             }
487              
488             # Convert Our format -> VCard
489             } else {
490             # Delete value if special "empty" value
491 0 0         return undef if $_ eq '0000-00-00';
492              
493             # Our format is V3 format
494              
495             # Convert to V4 format if V4 card
496 0 0         if ($Self->V('version') >= 4.0) {
497 0           my ($Y, $M, $D) = /^(\d{4})-(\d{2})-(\d{2})/;
498 0 0         $Y = '--' if $Y eq '0000';
499 0           $_ = $Y . $M . $D;
500             }
501              
502 0           return $_;
503             }
504              
505 0           return undef;
506             }
507             sub VRebuildFN {
508 0     0 0   my $Self = shift;
509              
510             my $NewFN = join " ", map {
511 0 0         $Self->V('n', $_) or ()
  0            
512             } qw(honorificprefixs givennames additionalnames surnames);
513              
514 0           my $Suffixes = $Self->V('n', 'honorificsuffixes');
515 0 0         $NewFN .= ', ' . $Suffixes if $Suffixes;
516              
517             # FN is a required field, so we have to set it to something
518 0 0         unless ($NewFN) {
519 0           $NewFN = $Self->VCompany();
520             }
521 0 0         unless ($NewFN) {
522 0           my ($Email) = $Self->VEmails();
523 0           $NewFN = $Email->{value};
524             }
525 0 0         unless ($NewFN) {
526 0           $NewFN = "No Name";
527             }
528              
529 0           $Self->V('fn', 'value', $NewFN);
530             }
531              
532             sub VTitle {
533 0     0 0   my $Self = shift;
534 0   0       $Self->V('n', 'honorificprefixs', @_) // '';
535             }
536             sub VFirstName {
537 0     0 0   my $Self = shift;
538 0 0         if (!@_) {
539 0 0         return join " ", map { $_ or () } $Self->V('n', 'givennames'), $Self->V('n', 'additionalnames');
  0            
540             } else {
541 0           my ($GivenNames, $AdditionalNames) = split / +/, $_[0], 2;
542 0           $Self->V('n', 'givennames', $GivenNames);
543 0           $Self->V('n', 'additionalnames', $AdditionalNames);
544             }
545             }
546             sub VLastName {
547 0     0 0   my $Self = shift;
548 0   0       $Self->V('n', 'surnames', @_) // '';
549             }
550              
551             sub VFN {
552 0     0 0   my $Self = shift;
553 0   0       $Self->V('fn', 'value', @_) // '';
554             }
555              
556             sub VNickname {
557 0   0 0 0   shift->V('nickname', 'value', @_) // '';
558             }
559             sub VBirthday {
560 0     0 0   my $Self = shift;
561 0 0         if (!@_) {
562 0   0       return $Self->VDate($Self->V('bday')) // '0000-00-00';
563             } else {
564 0           $Self->V('bday', 'value', $Self->VDate($_[0], 1));
565             }
566             }
567              
568             sub VCompany {
569 0   0 0 0   shift->V('org', 'company', @_) // '';
570             }
571             sub VDepartment {
572 0   0 0 0   shift->V('org', 'department', @_) // '';
573             }
574             sub VPosition {
575 0   0 0 0   shift->V('title', 'value', @_) // '';
576             }
577              
578             sub VNotes {
579 0   0 0 0   shift->V('note', 'value', @_) // '';
580             }
581              
582             my %VBasicTypeMap = (type => 'contact_type', value => 'value');
583             my %VOnlineTypeMap = (type => 'online_type', value => 'online_value');
584             my %VAdrTypeMap = (type => 'contact_type', street => 'streetaddress', city => 'locality', state => 'region', postcode => 'postalcode', country => 'countryname');
585             my %RevVAdrTypeMap = reverse %VAdrTypeMap;
586              
587             sub VKN {
588 0     0 0   my $I = shift;
589 0           join "/", map { $I->{$_} } @_;
  0            
590             }
591              
592             sub VIsSame {
593 0     0 0   my ($Self, $Prop, $E, $N) = @_;
594              
595 0 0 0       if ($Prop eq 'email' || $Prop eq 'tel') {
    0          
    0          
596             # If type or value is same, consider it the same item
597             return 1 if $N->{contact_type} eq $E->{contact_type}
598 0 0 0       || $N->{value} eq $E->{value};
599              
600             } elsif ($Prop eq 'adr') {
601             # If type or value is same, consider it the same item
602             return 1 if $N->{contact_type} eq $E->{contact_type}
603 0 0 0 0     || all { ($N->{$_} // '') eq $E->{$_} } @VItemADR;
  0   0        
604              
605             } elsif ($Prop eq 'online') {
606             # If synthetic online type AND value is same, consider it the same item
607             return 1 if $N->{contact_type} eq ($E->{online_type} // $E->{contact_type})
608 0 0 0       && $N->{value} eq ($E->{online_value} // $E->{value});
      0        
      0        
609              
610             } else {
611 0           die "Unknown prop: $Prop";
612             }
613             }
614              
615             sub VUpdateExisting {
616 0     0 0   my ($Self, $Prop, $E, $N, $TypeMap) = @_;
617              
618             # Need to update vcard specific properties
619 0 0         if (my $Maps = $VCardTypeMap{$Prop}) {
620 0 0         if (my $ParamType = $Maps->[1]->{$N->{contact_type}}) {
    0          
621             # Make sure only the single right type is present in the vcard type param
622 0   0       my $Types = ($E->{params}->{type} //= []);
623 0           @$Types = grep { !$Maps->[0]->{$_} } @$Types;
  0            
624 0           push @$Types, $ParamType;
625              
626             # Lets try and be smart and update any label
627 0 0         $Self->VUpdateLabel($E, $N) if $Prop eq 'adr';
628             }
629             elsif ($N->{contact_type} eq 'other') {
630 0           delete $E->{params}->{type};
631             }
632              
633             } else {
634 0           die "Unknown prop: $Prop";
635             }
636              
637             # Now copy over value(s)
638 0           $E->{$_} = $N->{$_} for values %$TypeMap;
639             }
640              
641             sub VUpdateLabel {
642 0     0 0   my ($Self, $E, $N) = @_;
643              
644 0           my @Labels;
645             # In v4, it's a parameter
646 0           push @Labels, map { \$_ } @{$E->{params}->{label}};
  0            
  0            
647              
648             # In v3, it's a separate property. Either in same group...
649 0 0         if (my $Group = $E->{group}) {
650 0           for (@{$E->{groups}->{$Group}}) {
  0            
651 0 0         push @Labels, \$_->{value} if $_->{name} eq 'label';
652             }
653             }
654             # ... or check for label with same type (e.g. 'work', 'home', etc)
655 0 0         if (!@Labels) {
656 0   0       my ($EType) = grep { $VCardAdrTypeMap{$_} } @{$E->{params}->{type} // []};
  0            
  0            
657 0           my $Labels = $Self->{properties}->{label};
658 0 0 0       if ($EType && $Labels) {
659 0           for (@$Labels) {
660 0   0       my ($Type) = grep { $VCardAdrTypeMap{$_} } @{$_->{params}->{type} // []};
  0            
  0            
661 0 0 0       push @Labels, \$_->{value} if $Type && $Type eq $EType;
662             }
663             }
664             }
665              
666 0           my @EI = @$E{@VItemADR};
667 0           my @NI = @$N{@VItemADR};
668              
669 0           for my $Label (@Labels) {
670             pairwise {
671 0 0   0     $$Label =~ s/\b\Q$a\E\b/$b/ if length $a >= 3;
672 0           } @EI, @NI;
673             }
674             }
675              
676             sub _MakeItem {
677 0     0     my ($Name, $Type, $Value, $Params, @Extra) = @_;
678             +{
679 0 0 0       name => $Name,
680             contact_type => $Type,
681             (ref $Value ? 'values' : 'value') => $Value,
682             params => $Params // {},
683             @Extra,
684             };
685             }
686              
687             sub VNewItem {
688 0     0 0   my ($Self, $Prop, $N) = @_;
689 0   0       my $Type = $N->{online_type} // $N->{contact_type};
690 0   0       my $Value = $N->{online_value} // $N->{value};
691              
692 0           my @New;
693              
694 0 0         if (my $Maps = $VCardTypeMap{$Prop}) {
    0          
695 0           my $Params = {};
696 0           my %Extra;
697              
698             # Set vcard type parameter
699 0 0         if (my $ParamType = $Maps->[1]->{$Type}) {
700 0           $Params->{type} = [ $ParamType ];
701             }
702              
703             # Expand address value into array ref components
704 0 0         if ($Prop eq 'adr') {
705 0           @Extra{@VItemADR} = @$N{@VItemADR};
706 0           $Value = [ \@Extra{@VItemADR} ];
707             }
708              
709 0 0         $Params->{$NoteParamName} = $N->{note} if $N->{note};
710 0 0         if ($N->{pref}) {
711 0   0       $Params->{type} //= [];
712 0           push @{$Params->{type}}, 'pref';
  0            
713             }
714              
715 0           push @New, _MakeItem($Prop, $Type, $Value, $Params, %Extra);
716             }
717              
718             elsif ($Prop eq 'online') {
719              
720 0   0       my $NewMap = $VCardNewOnlineMap{$Type} // $VCardNewOnlineMap{other};
721             push @New, _MakeItem($_->[0], $Type, $Value, $_->[1])
722 0 0         for @{ref $NewMap eq 'CODE' ? $NewMap->($N->{online_value}) : $NewMap};
  0            
723             }
724              
725             else {
726 0           die "Unknown prop: $Prop";
727             }
728              
729 0 0         if ($N->{note}) {
730 0           $_->{$NoteParamName} = $N->{note} for @New;
731             }
732 0 0         if ($N->{pref}) {
733 0           $_->{pref} = 1 for @New;
734             }
735              
736 0           return @New;
737             }
738              
739             sub VL {
740 0     0 0   my ($Self, $Prop, $TypeMap) = splice @_, 0, 3;
741 0           my $Props = $Self->{properties};
742              
743             die "Tried to modify read-only contact, fetch directly, not from cache"
744 0 0 0       if @_ && $Self->{ReadOnly};
745              
746 0   0       my @E = grep { !$_->{deleted} } @{$Props->{$Prop} // []};
  0            
  0            
747              
748             # Easy part, return items
749 0 0         if (!@_) {
750 0           my %Seen;
751             return map {
752 0           my $I = $_;
  0            
753             # dedup. this might be wrong if the second has pref or note
754 0           my $VKN = VKN($I, values %$TypeMap);
755 0 0         if ($Seen{$VKN}) {
756 0           ();
757             }
758             else {
759 0           $Seen{$VKN} = 1;
760 0     0     my %Props = mapp { ($a => $I->{$b}) } %$TypeMap;
  0            
761 0 0 0       $Props{pref} = 1 if grep { $_ eq 'pref' } @{$_->{params}->{type} // []};
  0            
  0            
762 0 0         $Props{note} = $_->{params}->{$NoteParamName}->[0] if $_->{params}->{$NoteParamName};
763 0           \%Props;
764             }
765             } @E;
766              
767             # Harder part, set items. Try and preserve existing items
768             } else {
769 0           $Self->{vchanged}->{$Prop} = 1;
770              
771             # Find exact existing matches moved to different spot
772 0           my %EMap = map { VKN($_, values %$TypeMap) => $_ } @E;
  0            
773              
774 0           my $Pos = 0;
775              
776 0           my @R;
777 0           for my $New (@_) {
778 0   0 0     my $N = { mapp { $b => ($New->{$a} // '') } %$TypeMap };
  0            
779              
780 0           my @NewItems;
781              
782             # Exact existing item exists (maybe different position)
783 0 0         if (my $E = delete $EMap{VKN($N, values %$TypeMap)}) {
784 0           push @NewItems, $E;
785              
786             } else {
787 0           my $E = $E[$Pos];
788              
789             # Same item in same position, update value(s)
790             # Not for online though, we always replace those
791 0 0 0       if ($Prop ne 'online' && $E && $Self->VIsSame($Prop, $E, $N)) {
      0        
792             # Don't re-use this item
793 0           delete $EMap{VKN($E, values %$TypeMap)};
794              
795 0           $Self->VUpdateExisting($Prop, $E, $N, $TypeMap);
796              
797 0           push @NewItems, $E;
798             }
799              
800             # Add new item!
801             else {
802 0           push @NewItems, $Self->VNewItem($Prop, $N);
803              
804             }
805             }
806              
807 0 0         if (my $Note = $New->{note}) {
808 0           $_->{params}->{$NoteParamName} = [ $Note ] for @NewItems;
809             } else {
810 0           delete $_->{params}->{$NoteParamName} for @NewItems;
811             }
812              
813 0 0         if ($New->{pref}) {
814 0           for (@NewItems) {
815 0   0       $_->{params}->{type} //= [];
816 0           push @{$_->{params}->{type}}, 'pref';
  0            
817             }
818             } else {
819 0           for (@NewItems) {
820 0   0       $_->{params}->{type} //= [];
821 0           @{$_->{params}->{type}} = grep { $_ ne 'pref' } @{$_->{params}->{type}};
  0            
  0            
  0            
822             }
823             }
824              
825             # Always add to result list
826 0           push @R, @NewItems;
827 0           $Pos += @NewItems;
828             }
829              
830             # For tel, email, adr, just replace list
831 0 0 0       if ($Prop eq 'email' || $Prop eq 'tel' || $Prop eq 'adr') {
    0 0        
832 0           @{$Props->{$Prop}} = @R;
  0            
833              
834             } elsif ($Prop eq 'online') {
835             # Maps to multiple props. Delete the old ones of types we're replacing
836 0           my %ReplaceTypes = map { $_->{contact_type} => 1 } @R;
  0            
837 0           $_->{deleted} = 1 for grep { $ReplaceTypes{$_->{online_type}} } @E;
  0            
838              
839 0           push @{$Props->{$Prop}}, @R;
  0            
840              
841             } else {
842 0           die "Unknown prop: $Prop";
843             }
844              
845 0           $Self->DeleteUnusedLabels;
846              
847 0 0         $Self->VRebuildFN if $Prop eq 'email';
848             }
849             }
850              
851             sub VEmails {
852 0     0 0   shift->VL('email', \%VBasicTypeMap, @_);
853             }
854             sub VPhones {
855 0     0 0   shift->VL('tel', \%VBasicTypeMap, @_);
856             }
857             sub VOnline {
858 0     0 0   shift->VL('online', \%VOnlineTypeMap, @_);
859             }
860             sub VAddresses {
861 0     0 0   shift->VL('adr', \%VAdrTypeMap, @_);
862             }
863              
864             sub VKind {
865 0   0 0 0   shift->V('x-addressbookserver-kind', 'value', @_) // 'contact';
866             }
867              
868             sub VGroupContactUIDs {
869 0     0 0   my $Self = shift;
870 0           my $Props = $Self->{properties};
871              
872             die "Tried to modify read-only contact, fetch directly, not from cache"
873 0 0 0       if @_ && $Self->{ReadOnly};
874              
875 0 0         if (!@_) {
876             return
877 0           map { s/^urn://; s/^uuid://; $_ }
  0            
  0            
878 0           map { $_->{value} }
879 0 0         @{$Props->{'x-addressbookserver-member'} ||[]};
  0            
880              
881             } else {
882 0           @{$Props->{'x-addressbookserver-member'}} = map {
883             {
884 0           name => 'x-addressbookserver-member',
885             params => {},
886             value => 'urn:uuid:' . $_,
887             }
888 0           } @{$_[0]};
  0            
889              
890 0           $Self->{vchanged}->{'x-addressbookserver-member'} = 1;
891              
892 0           return @{$_[0]};
  0            
893             }
894              
895             }
896              
897             sub VGroupIds {
898 0     0 0   my $Self = shift;
899 0 0         !@_ || die "You can't set GroupIds on a contact, use ME::CalDAV::UpdateGroups";
900 0 0         return sort keys %{$Self->{ABGroups} || {}};
  0            
901             }
902              
903             sub VChanged {
904 0     0 0   my $Self = shift;
905 0   0       return keys %{$Self->{vchanged} // {}};
  0            
906             }
907             sub VClearChanged {
908 0     0 0   my $Self = shift;
909 0           delete $Self->{vchanged};
910             }
911              
912             sub MFlagged {
913 0   0 0 0   return shift->MMeta('SF:flagged', @_) || 0;
914             }
915             sub MImportance {
916             # Defaults to empty string, make it a number
917 0   0 0 0   return shift->MMeta('CY:importance', @_) || 0;
918             }
919             sub MMeta {
920 0     0 0   my ($Self, $Prop) = (shift, shift);
921 0 0         if (@_) {
922 0           $Self->{meta}->{$Prop} = shift;
923 0           $Self->{metachanged}->{$Prop} = 1;
924             }
925 0           return $Self->{meta}->{$Prop};
926             }
927              
928             sub MChanged {
929 0     0 0   my $Self = shift;
930 0   0       return map { [ $_, $Self->{meta}->{$_} ] } keys %{$Self->{metachanged} // {}};
  0            
  0            
931             }
932             sub MClearChanged {
933 0     0 0   my $Self = shift;
934 0           delete $Self->{metachanged};
935             }
936              
937             # }}}
938              
939             1;