File Coverage

blib/lib/App/Addex/AddressBook/AppleScript.pm
Criterion Covered Total %
statement 26 109 23.8
branch 0 38 0.0
condition 0 18 0.0
subroutine 9 15 60.0
pod 1 1 100.0
total 36 181 19.8


line stmt bran cond sub pod time code
1 1     1   61990 use 5.20.0;
  1         12  
2 1     1   5 use strict;
  1         1  
  1         22  
3 1     1   4 use warnings;
  1         10  
  1         57  
4             package App::Addex::AddressBook::AppleScript 0.009;
5              
6 1     1   450 use parent qw(App::Addex::AddressBook);
  1         275  
  1         5  
7 1     1   22070 use experimental 'postderef';
  1         3130  
  1         6  
8             # ABSTRACT: Mac::Glue-less Addex adapter for Apple Address Book and Addex
9              
10             #pod =head1 SYNOPSIS
11             #pod
12             #pod This module implements the L<App::Addex::AddressBook> interface for Mac OS X's
13             #pod Address Book application, using I<a horrible hack> to get entries from the
14             #pod address book.
15             #pod
16             #pod A much cleaner interface would be to use L<App::Addex::AddressBook::Apple>,
17             #pod which uses L<Mac::Glue> to access the address book. Unfortunately, Mac::Glue
18             #pod does not work in many recent builds of Perl, and will cease to work as the
19             #pod Carbon API is killed off.
20             #pod
21             #pod The AppleScript adapter builds an AppleScript program that prints out a dump of
22             #pod relevant address book entries, then runs it, then parses its output. The
23             #pod format of the intermediate form may change for all kinds of crazy reasons.
24             #pod
25             #pod =cut
26              
27 1     1   195 use App::Addex::Entry;
  1         2  
  1         21  
28 1     1   633 use App::Addex::Entry::EmailAddress;
  1         342  
  1         25  
29 1     1   510 use Encode ();
  1         9609  
  1         27  
30              
31 1     1   656 use File::Temp ();
  1         17491  
  1         1348  
32              
33             sub _produce_applescript {
34 0     0     my @fields = (
35             'company', # true / false
36             'organization',
37             'first name',
38             'middle name',
39             'last name',
40             'nickname',
41             'suffix',
42             'note',
43             );
44              
45 0           my $dumper = '';
46 0           for my $field (@fields) {
47 0           $dumper .= <<"END_FIELD_DUMPER";
48             set _this to get $field of _person
49             if $field of _person is not missing value then
50             set _answer to _answer & "- BEGIN $field\n"
51             set _answer to _answer & ($field of _person) & "\n"
52             set _answer to _answer & "- END $field\n"
53             end if
54             END_FIELD_DUMPER
55             }
56              
57 0           my $osascript = <<'END_APPLESCRIPT';
58             tell application "Address Book"
59             set _people to (get people)
60              
61             set _answer to ""
62              
63             repeat with _person in _people
64             repeat 1 times
65             if count of email of _person = 0 then
66             exit repeat
67             end if
68              
69             set _answer to _answer & "--- BEGIN " & id of _person & "\n"
70              
71             $dumper
72              
73             set _answer to _answer & "- BEGIN email\n"
74             repeat with _email in (get email of _person)
75             set _answer to _answer & (label of _email) & "\n"
76             set _answer to _answer & (value of _email) & "\n"
77             end repeat
78             set _answer to _answer & "- END email\n"
79              
80             set _answer to _answer & "--- END " & id of _person & "\n\n"
81             end repeat
82             end repeat
83              
84             _answer
85             end tell
86             END_APPLESCRIPT
87              
88 0           $osascript =~ s/\$dumper/$dumper/;
89              
90 0           return $osascript;
91             }
92              
93             sub _produce_scriptfile {
94 0     0     my ($self) = @_;
95              
96 0           my $osascript = $self->_produce_applescript;
97              
98 0           my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1);
99              
100 0           $fh->print($osascript);
101 0 0         $fh->close or die "can't close $filename: $!";
102              
103 0           return $filename;
104             }
105              
106             sub entries {
107 0     0 1   my ($self) = @_;
108              
109 0           my $script = $self->_produce_scriptfile;
110 0           my @output = `/usr/bin/osascript $script`;
111              
112 0           @output = map {; Encode::decode('utf-8', $_) } @output;
  0            
113              
114 0           my @people;
115             my $this;
116 0           LINE: while (my $line = shift @output) {
117 0 0         unless ($this) {
118 0 0         next LINE unless $line =~ /\A--- BEGIN (.+)\Z/;
119 0           $this = { id => $1 };
120 0           push @people, $this;
121 0           next LINE;
122             }
123              
124 0           my @input;
125 0 0         if ($line =~ /\A- BEGIN (.+)\Z/) {
126 0           my $field = $1;
127 0   0       push @input, shift @output until @input and $input[-1] =~ /\A- END $1\Z/;
128 0           pop @input;
129 0           $this->{ $field } = join q{}, @input;
130 0           chomp $this->{ $field };
131              
132 0 0         if ($field eq 'email') {
133 0           $this->{emails} = [ split /\n/, delete $this->{email} ];
134             }
135             }
136              
137 0 0         if ($line =~ /\A--- END \Q$this->{id}\E\Z/) {
138 0           undef $this;
139 0           next LINE;
140             }
141             }
142              
143 0           my @entries = map {; $self->_entrify($_) } @people;
  0            
144              
145 0           return @entries;
146             }
147              
148             sub _entrify {
149 0     0     my ($self, $person) = @_;
150              
151 0           my %fields;
152 0 0 0       if (my $note = $person->{note} // '') {
153 0           my @lines = grep { length } split /\R/, $note;
  0            
154 0           for my $line (@lines) {
155 0 0         next if $line =~ /^--/; # comment
156              
157             my $tmpname
158             = join q{ }, grep $_,
159 0           $person->@{'first name', 'middle name', 'last name', 'suffix'};
160              
161 0 0         warn("bogus line in notes on $tmpname: $line\n"), next
162             unless $line =~ /\A([^:]+):\s*(.+?)\Z/;
163 0           $fields{$1} = $2;
164             }
165             }
166              
167 0   0       my $fname = $person->{'first name'} // '';
168 0   0       my $mname = $person->{'middle name'} // '';
169 0   0       my $lname = $person->{'last name'} // '';
170 0   0       my $suffix = $person->{suffix} // '';
171              
172 0 0 0       $mname = '' unless $fields{'use middle'} // 1;
173              
174 0           my $name;
175 0 0         if ($person->{company} eq 'true') {
176 0           $name = $person->{organization};
177             } else {
178 0 0         $name = $fname
    0          
    0          
179             . (length $mname ? " $mname" : '')
180             . (length $lname ? " $lname" : '')
181             . (length $suffix ? " $suffix" : '');
182             }
183              
184 0 0         unless (length $name) {
185 0           warn "couldn't figure out a name for this entry\n";
186 0           return;
187             }
188              
189 0           my @emails;
190 0           my @kv = @{ $person->{emails} };
  0            
191              
192 0           for (my $i = 0; $i < $#kv; $i += 2) {
193 0           push @emails, App::Addex::Entry::EmailAddress->new({
194             address => $kv[ $i + 1 ],
195             label => $kv[ $i ],
196             });
197             }
198              
199             CHECK_DEFAULT: {
200 0 0 0       if (@emails > 1 and my $default = $fields{default_email}) {
  0            
201 0           my $check;
202 0 0         if ($default =~ m{\A/(.+)/\z}) {
203 0           $default = qr/$1/;
204 0     0     $check = sub { $_[0]->address =~ $default };
  0            
205             } else {
206 0     0     $check = sub { $_[0]->label eq $default };
  0            
207             }
208              
209 0           for my $i (0 .. $#emails) {
210 0 0         if ($check->($emails[$i])) {
211 0 0         unshift @emails, splice @emails, $i, 1 if $i != 0;
212 0           last CHECK_DEFAULT;
213             }
214             }
215              
216 0           warn "no email found for $name matching $fields{default_email}\n";
217             }
218             }
219              
220             my $arg = {
221             name => $name,
222             nick => $person->{nickname},
223 0           emails => \@emails,
224             fields => \%fields,
225             };
226              
227 0           return App::Addex::Entry->new($arg);
228             }
229              
230             1;
231              
232             __END__
233              
234             =pod
235              
236             =encoding UTF-8
237              
238             =head1 NAME
239              
240             App::Addex::AddressBook::AppleScript - Mac::Glue-less Addex adapter for Apple Address Book and Addex
241              
242             =head1 VERSION
243              
244             version 0.009
245              
246             =head1 SYNOPSIS
247              
248             This module implements the L<App::Addex::AddressBook> interface for Mac OS X's
249             Address Book application, using I<a horrible hack> to get entries from the
250             address book.
251              
252             A much cleaner interface would be to use L<App::Addex::AddressBook::Apple>,
253             which uses L<Mac::Glue> to access the address book. Unfortunately, Mac::Glue
254             does not work in many recent builds of Perl, and will cease to work as the
255             Carbon API is killed off.
256              
257             The AppleScript adapter builds an AppleScript program that prints out a dump of
258             relevant address book entries, then runs it, then parses its output. The
259             format of the intermediate form may change for all kinds of crazy reasons.
260              
261             =head1 PERL VERSION SUPPORT
262              
263             This module has the same support period as perl itself: it supports the two
264             most recent versions of perl. (That is, if the most recently released version
265             is v5.40, then this module should work on both v5.40 and v5.38.)
266              
267             Although it may work on older versions of perl, no guarantee is made that the
268             minimum required version will not be increased. The version may be increased
269             for any reason, and there is no promise that patches will be accepted to lower
270             the minimum required perl.
271              
272             =head1 AUTHOR
273              
274             Ricardo Signes <rjbs@semiotic.systems>
275              
276             =head1 COPYRIGHT AND LICENSE
277              
278             This software is copyright (c) 2010 by Ricardo Signes.
279              
280             This is free software; you can redistribute it and/or modify it under
281             the same terms as the Perl 5 programming language system itself.
282              
283             =cut